恳请高手师傅们再帮忙看下这个分类的难题

qiongmei6

这个难题今天早上发出来过，好多大神也给了答案，但是现在表格有了改变，把大神们代码上下左右打量都不知道咋修改能达到我的表格要求，只好重新发上来重新请大神们再帮忙看下，现在表格的需求是找出凡是有“工资”或者“物贴”表格中的a：c列把不属于广州集中在“汇总”表格中g2：h列（每个账号是唯一，虽然里头可能有些账号单位不同，但单位只显示其中一个单位，这个工作簿中找的数据只在名字是工资或者物贴表里头找），把属于广州的集中在“汇总”表格中j2：k列（每个账号是唯一），目前“汇总”表格中g2：h列，j2：k列就是我希望代码执行后得到的数据，再次谢谢大神们的帮忙

ykcbf1100

这个求助和上次发的看上去一样啊。

ykcbf1100

本来原代码可以用的，你还说帐号是唯一的，问题就在于这里，广州和非广州就有帐号是相同的，造成数据缺失，加一个字典解决。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.15
   
2.     Dim arr, brr(1 To 10000, 1 To 6)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     st = "广州"
   
6.     Set sh = ThisWorkbook.Sheets("汇总")
   
7.     For Each sht In Sheets
   
8.         If InStr(sht.Name, "工资") Or InStr(sht.Name, "物贴") Then
   
9.             With sht
   
10.                 r = .Cells(Rows.Count, 1).End(3).Row
    
11.                 arr = .Range("a1:c" & r)
    
12.             End With
    
13.             For i = 2 To UBound(arr)
    
14.                 s = CStr(arr(i, 2))
    
15.                 If arr(i, 1) <> st Then
    
16.                     If Not d.exists(s) Then
    
17.                         m = m + 1
    
18.                         d(s) = m
    
19.                         For j = 1 To 3
    
20.                             brr(m, j) = arr(i, j)
    
21.                         Next
    
22.                     End If
    
23.                 Else
    
24.                     If Not d1.exists(s) Then
    
25.                         n = n + 1
    
26.                         d1(s) = n
    
27.                         For j = 1 To 3
    
28.                             brr(n, j + 3) = arr(i, j)
    
29.                         Next
    
30.                     End If
    
31.                 End If
    
32.             Next
    
33.         End If
    
34.     Next
    
35.     With sh
    
36.         .[g8:l1000] = ""
    
37.         .Range("h:h,k:k").NumberFormatLocal = "@"
    
38.         .[g8].Resize(IIf(m > n, m, n), 6) = brr
    
39.     End With
    
40. End Sub
    
41. 
    
42. 
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, cr, i&, j&, dic As Object
    Dim strJoin$, wks As Worksheet, r1&, r2&
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    For Each wks In Worksheets
        If wks.Name <> "汇总" Then
            With wks
                ar = Range(.[A2], .Cells(Rows.Count, "C").End(xlUp)).Value
                For i = 2 To UBound(ar)
                    strJoin = Join(Application.Index(ar, i))
                    dic(strJoin) = Application.Index(ar, i)
                Next i
            End With
        End If
    Next
    ar = Application.Rept(dic.items, 1)
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    ReDim cr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 1 To UBound(ar)
        If ar(i, 1) = "广州" Then
            r2 = r2 + 1
            For j = 1 To UBound(ar, 2)
                cr(r2, j) = ar(i, j)
            Next j
        Else
            r1 = r1 + 1
            For j = 1 To UBound(ar, 2)
                br(r1, j) = ar(i, j)
            Next j
        End If
    Next i
   
    [G8].CurrentRegion.Clear
    [G8].Resize(r1, UBound(ar, 2)) = br
    [J8].Resize(r2, UBound(ar, 2)) = cr

    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

请参考。。。