总表数据罗列到分表中

njwtg

老师好，我想实现的功能是：
从第二行开始
第一步：将F列的数据不重复的提取到D列（如黄色所示）
第二步：将D列的省份信息对应的表名，如“北京”对应的是“表1”，将JK列数据复制到对应的“表1”中的OP列，表有30个，如各分表中的黄色所示
谢谢老师！

cjc209

这题简单            

cjc209

jsa 宏 自定义函数代码 就几句代码搞定
function test(){
        var rs=[];
        maxArray_Z("汇总表!f2").distinct_Z().toRange_Z("汇总表!d2");
   var arr=maxArray_Z("汇总表!a2:d2","d").selectCols_Z("f1").flat();
   arr.map(bm=>rs=rs.concat(maxArray_Z(bm+"!o2:p2")));  
        rs.toRange_Z("汇总表!j2")       
}

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.20
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("汇总表")
   
6.         r = .Cells(Rows.Count, 6).End(3).Row
   
7.         arr = .Range("f1:k" & r)
   
8.         For i = 2 To UBound(arr)
   
9.             s = arr(i, 1)
   
10.             d(s) = ""
    
11.         Next
    
12.         .[d2:d1000] = ""
    
13.         .[d2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
14.         zrr = .Range("a2:d" & d.Count + 1)
    
15.     End With
    
16.     For x = 1 To UBound(zrr)
    
17.         s = zrr(x, 4)
    
18.         d1(s) = zrr(x, 1)
    
19.         m = 0
    
20.         ReDim brr(1 To UBound(arr), 1 To 2)
    
21.         For i = 2 To UBound(arr)
    
22.             If arr(i, 1) = s Then
    
23.                 m = m + 1
    
24.                 brr(m, 1) = arr(i, 5)
    
25.                 brr(m, 2) = arr(i, 6)
    
26.                 With Sheets(d1(s))
    
27.                     .[o2:p1000] = ""
    
28.                     .[o2].Resize(m, 2) = brr
    
29.                 End With
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     Set d = Nothing
    
34.     MsgBox "OK！"
    
35. End Sub
    
36. 
    

复制代码

ykcbf1100

附件供参考。。。

njwtg

谢谢ykcbf1100老师。好用！

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, dic As Object, Rng As Range
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Range("F1", Cells(Rows.Count, "K").End(xlUp))
        ar = .Value
        Set Rng = .Cells(1, 5).Resize(, 2)
        For i = 2 To UBound(ar)
            If Not dic.exists(ar(i, 1)) Then
                Set dic(ar(i, 1)) = Rng
            End If
            Set dic(ar(i, 1)) = Union(dic(ar(i, 1)), .Cells(i, 5).Resize(, 2))
        Next
    End With
   
    For i = 0 To dic.Count - 1
        With Worksheets(Cells(i + 2, 1).Value)
            .Cells.Clear
            dic.items()(i).Copy .[O1]
        End With
    Next i
   
    Range("D1", Cells(Rows.Count, "D").End(xlUp)).Offset(1).Clear
    [d2].Resize(dic.Count) = Application.Transpose(dic.keys)
    Set dic = Nothing: Set Rng = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。