提取在合并单元格字符

chxw68

早晨起床没事，直接写了两段代码实现两个汇总表的数据统计供楼主参考。

今日123

gwjkkkkk 发表于 2024-12-15 09:22
Sub 提取字符()
Dim str, k, strName$
For i = 1 To Sheets.Count - 2

谢谢老师花等晚点送上

今日123

chxw68 发表于 2024-12-15 09:28
早晨起床没事，直接写了两段代码实现两个汇总表的数据统计供楼主参考。

谢谢老师花晚点送上，老师的代码收藏好多，学习写vba 是从读老师写的代码开始的

今日123

ykcbf1100 发表于 2024-12-15 07:35
只提取单位名,不用干别的?

谢谢老师，花晚点送

cnmlgb9998

楼主数据与描述不一致，同一名字 有 非唯一的银行名称。 太随意了。

是这个效果吗？？？？？？？？？

PQ 方案！！！！！！！！！

chxw68

今日123 发表于 2024-12-15 13:33
谢谢老师花晚点送上，老师的代码收藏好多，学习写vba 是从读老师写的代码开始的

你的SHEET名称很规范，实际上依据SHEET名称判断更简单。

chxw68

1. Sub test3()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Dim d(1 To 2) As Object
   
6.     For k = 1 To 2
   
7.         Set d(k) = CreateObject("scripting.dictionary")
   
8.     Next
   
9.     For Each ws In Worksheets
   
10.         If Left(ws.Name, 2) <> "汇总" Then
    
11.             With ws
    
12.                 xm = Left(ws.Name, Len(ws.Name) - 1)
    
13.                 lx = Val(Right(ws.Name, 1))
    
14.                 r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.                 arr = .Range("a4:g" & r)
    
16.                 If Not d(1).exists(xm) Then
    
17.                     ReDim brr(1 To 6)
    
18.                     brr(2) = xm & "幼儿园"
    
19.                 Else
    
20.                     brr = d(1)(xm)
    
21.                 End If
    
22.                 brr(2 + lx) = arr(UBound(arr), 3)
    
23.                 d(1)(xm) = brr
    
24.                 For i = 1 To UBound(arr) - 1
    
25.                     If Len(arr(i, 4)) > 4 Then
    
26.                         If Not d(2).exists(arr(i, 4)) Then
    
27.                             ReDim brr(1 To 8)
    
28.                             brr(2) = arr(i, 4)
    
29.                             brr(6) = arr(i, 5)
    
30.                             brr(7) = arr(i, 6)
    
31.                         Else
    
32.                             brr = d(2)(arr(i, 4))
    
33.                         End If
    
34.                         brr(2 + lx) = brr(2 + lx) + arr(i, 3)
    
35.                         d(2)(arr(i, 4)) = brr
    
36.                     End If
    
37.                 Next
    
38.             End With
    
39.         End If
    
40.     Next
    
41.     For k = 1 To 2
    
42.         ls = IIf(k = 1, 6, 8)
    
43.         ReDim crr(1 To d(k).Count, 1 To ls)
    
44.         ReDim drr(1 To ls)
    
45.         drr(1) = "合计"
    
46.         m = 0
    
47.         For Each aa In d(k).keys
    
48.             m = m + 1
    
49.             brr = d(k)(aa)
    
50.             brr(1) = m
    
51.             brr(5) = brr(3) + brr(4)
    
52.             For j = 1 To UBound(brr)
    
53.                 crr(m, j) = brr(j)
    
54.             Next
    
55.             For j = 3 To 5
    
56.                 drr(j) = drr(j) + brr(j)
    
57.             Next
    
58.         Next
    
59.         With Worksheets("汇总" & k)
    
60.             .UsedRange.Offset(3, 0).Clear
    
61.             If k = 2 Then
    
62.                 .Columns(6).NumberFormatLocal = "@"
    
63.             End If
    
64.             .Range("a4").Resize(UBound(crr), UBound(crr, 2)) = crr
    
65.             .Cells(3 + UBound(crr) + 1, 1).Resize(1, UBound(drr)) = drr
    
66.             With .Range("a3").Resize(1 + UBound(crr) + 1, ls)
    
67.                 .Borders.LineStyle = xlContinuous
    
68.                 .HorizontalAlignment = xlCenter
    
69.                 .VerticalAlignment = xlCenter
    
70.             End With
    
71.         End With
    
72.     Next
    
73. End Sub
    

复制代码

chxw68

练习，将两段代码合为一段。

ykcbf1100

shiruiqiang 发表于 2024-12-15 08:09
单位后面还有日期

按照1楼的城需求说明,应该就提取单位,日期不用管.

chxw68

ykcbf1100 发表于 2024-12-15 16:34
按照1楼的城需求说明,应该就提取单位,日期不用管.

A2单元格是合并单元格，你取的K值单位名称后面跟了一个“填报时间"。