大神们，请问如何将单个工作总表某列不同的值拆分成多个其他的工作表？万分感谢

rosedowson

不知道为什么 发表于 2018-9-6 22:24
参考

Sub test1()
Dim sht As Worksheet, arr, D1, D2, D3
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
Set D3 = CreateObject("scripting.dictionary")
Set k1 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Worksheets
If sht.Name <> "总表" And sht.Name <> "模版" Then sht.Delete
Next
With Sheets("总表")
arr = .Range("a2").CurrentRegion
For i = 3 To UBound(arr)
If Len(Trim(arr(i, 2))) Then
D1(Trim(arr(i, 2))) = arr(i, 5) & "#" & arr(i, 3) & "#" & arr(i, 4)
If Not D2.exists(Trim(arr(i, 2))) Then
Set D2(Trim(arr(i, 2))) = .Cells(i, "g").Resize(1, 11)
Else
Set D2(Trim(arr(i, 2))) = Union(D2(Trim(arr(i, 2))), .Cells(i, "g").Resize(1, 11))
End If
If Not D3.exists(Trim(arr(i, 2))) Then
Set D3(Trim(arr(i, 2))) = .Cells(i, "s").Resize(1, 2)
Else
Set D3(Trim(arr(i, 2))) = Union(D3(Trim(arr(i, 2))), .Cells(i, "s").Resize(1, 2))
End If
End If
Next i
End With
For Each k1 In D1.Keys
Sheets("模版").Copy after:=Sheets("模版")
With ActiveSheet
.Name = k1
.[j1] = k1
For i = 5 To 7
.Cells(i, "c") = Split(D1(k1), "#")(i - 5)
Next i
End With
Next
For Each sht In Worksheets
If D2.exists(sht.Name) Then
D2(sht.Name).Copy sht.[b9]
End If
If D3.exists(sht.Name) Then
D3(sht.Name).Copy sht.[b22]
End If
Next
Set D1 = Nothing: Set D2 = Nothing: Set D3 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


感谢