求从总表分出分表代码

werqq

要求如附件

sunya_0529

这种简单的分拆，论坛上现成的案例一搜一大把，自己琢磨一下更有进步。


给一个JSA的示例——

shiruiqiang

论坛搜素一下分表就行，字典处理

werqq

sunya_0529 发表于 2024-9-29 21:10
这种简单的分拆，论坛上现成的案例一搜一大把，自己琢磨一下更有进步。

附件没有宏？

ykcbf1100

我写一个吧,总表拆分为多表

ykcbf1100

参与一下...

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, dic As Object, vKey, Rng As Range

    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    With Worksheets(1).[A1].CurrentRegion
        ar = .Value
        Set Rng = .Rows(1)
        For i = 2 To UBound(ar)
            If Not dic.exists(ar(i, 2)) Then
                Set dic(ar(i, 2)) = Rng
            End If
            Set dic(ar(i, 2)) = Union(dic(ar(i, 2)), .Rows(i))
        Next
    End With
   
    For Each vKey In dic.keys
        On Error Resume Next
            Worksheets(vKey).Delete
        On Error GoTo 0
        With Worksheets.Add(after:=Worksheets(Worksheets.Count))
            .Name = vKey
            dic(vKey).Copy
            .[A1].PasteSpecial xlPasteColumnWidths
            dic(vKey).Copy .[A1]
        End With
    Next

    Set dic = Nothing: Set Rng = Nothing
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

gwjkkkkk

参与一下。。。

张小生

详见附件，写一段代码，很长时间没写了，生疏了

1. Sub mytest1()
   
2. Application.ScreenUpdating = False
   
3. Dim ar, dr, br(1 To 100000, 1 To 5), m, n, c, j
   
4. Dim sortedlist As Object
   
5. Set sortedlist = CreateObject("System.collections.sortedlist")
   
6. dr = Sheet1.Range("a1:e1")
   
7. ar = Sheet1.Range("b2:e17")
   
8. For m = 1 To UBound(ar)
   
9.     sortedlist(ar(m, 1)) = ""
   
10. Next m
    
11. For n = 0 To sortedlist.Count - 1
    
12.     For c = 1 To UBound(ar)
    
13.         If ar(c, 1) = sortedlist.getkey(n) Then
    
14.             j = j + 1
    
15.             br(j, 1) = j
    
16.             br(j, 2) = ar(c, 1)
    
17.             br(j, 3) = ar(c, 2)
    
18.             br(j, 4) = ar(c, 3)
    
19.             br(j, 5) = ar(c, 4)
    
20.         End If
    
21.     Next c
    
22.     Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
    
23.     sh.Name = sortedlist.getkey(n)
    
24.     sh.Range("a1").Resize(1, UBound(dr, 2)) = dr
    
25.     sh.Range("a2").Resize(UBound(br), 5) = br
    
26.     Erase br
    
27.     j = 0
    
28.     Set sh = Nothing
    
29. Next n
    
30. Application.ScreenUpdating = True
    
31. End Sub

复制代码

kyxfyzg

参与一下。。。。。。。。。