数组套字典练习，要求如题

liuts

拆分工作表.rar (11.47 KB, 下载次数: 97)

2012-2-8 10:10 上传

点击文件名下载附件
按照A\B\C表的字段，拆分X工作表（复制X工作表即可，不用删除）
A\B\C字段不固定，可更改。

wcymiss

1. Sub cs()
   
2.     Dim d As Object, sh As Worksheet
   
3.     Dim i As Long, icol As Long, irow As Long, j As Long, col As Long, y As Long
   
4.     Dim arr, trr, trr2, brr()
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("X")
   
7.         icol = .Range("a1").End(2).Column
   
8.         irow = .Cells(Rows.Count, 1).End(3).Row
   
9.         trr = .Range("a1", .Cells(1, icol))
   
10.         arr = .Range("a2", .Cells(irow, icol + 1)) '多设一列用于容错
    
11.     End With
    
12.     For i = 1 To icol
    
13.         d(trr(1, i)) = i
    
14.     Next
    
15.     If d.Count > 0 Then
    
16.         For Each sh In ThisWorkbook.Sheets
    
17.             If sh.Name <> "X" Then
    
18.                 ReDim brr(1 To irow - 1, 1 To icol)
    
19.                 With sh
    
20.                     col = .Range("a1").End(2).Column
    
21.                     trr2 = .Range("a1", .Cells(1, col))
    
22.                     For j = 1 To col
    
23.                         If d.Exists(trr2(1, j)) Then '容错
    
24.                             y = d(trr2(1, j))
    
25.                         Else
    
26.                             y = icol + 1
    
27.                         End If
    
28.                         For i = 1 To irow - 1
    
29.                             brr(i, j) = arr(i, y)
    
30.                         Next
    
31.                     Next
    
32.                     .Range("a2", .Cells(Rows.Count, Columns.Count)).ClearContents
    
33.                     .Range("a2").Resize(irow - 1, col) = brr
    
34.                 End With
    
35.             End If
    
36.         Next
    
37.     End If
    
38.     Set d = Nothing
    
39.     Set sh = Nothing
    
40. End Sub

复制代码

sunjing-zxl

1. Sub aa()
   
2.     Dim d As New Dictionary
   
3.     Dim sh As Worksheet
   
4.     Dim arr1, arr2, arr3
   
5.     Dim Ro As Long, Co As Long
   
6.     Dim i As Long, j As Long, n As Long
   
7.     Application.ScreenUpdating = False
   
8.     arr1 = Range("A1:J" & [A65536].End(xlUp).Row)
   
9.     For i = 1 To UBound(arr1, 2)
   
10.         d(arr1(1, i)) = i
    
11.     Next i
    
12.     Ro = UBound(arr1)
    
13.     For Each sh In ThisWorkbook.Sheets
    
14.         If sh.Name <> "X" Then
    
15.             n = n + 1
    
16.             With sh
    
17.                 Co = .Range("A1").End(xlToRight).Column
    
18.                 arr2 = .Range(.Cells(1, 1), .Cells(1, Co))
    
19.                 ReDim arr3(1 To Ro - 1, 1 To Co)
    
20.                 For i = 1 To Ro - 1
    
21.                     For j = 1 To Co
    
22.                         arr3(i, j) = arr1((i + 1), d(arr2(1, j)))
    
23.                     Next j
    
24.                 Next i
    
25.                 .Range(.Cells(2, 1), .Cells(.[A65536].End(xlUp).Row + 1, .[IV2].End(xlToLeft).Column)).ClearContents
    
26.                 .Range("A2").Resize(UBound(arr3), UBound(arr3, 2)) = arr3
    
27.             End With
    
28.         End If
    
29.     Next sh
    
30.     Application.ScreenUpdating = True
    
31. End Sub

复制代码

csmctjg

1. Sub aa()
   
2. Dim i%, j%, arr, brr, crr(), d As Object
   
3. arr = Sheets("X").Range("A1:J1")
   
4. brr = Sheets("X").Range("A2:J" & Sheets("X").Range("A" & Rows.Count).End(3).Row)
   
5. Set d = CreateObject("scripting.dictionary")
   
6. For i = 1 To UBound(arr, 2)
   
7.     d(arr(1, i)) = Application.Index(brr, 0, i)
   
8. Next i
   
9. crr = Array("A", "B", "C")
   
10. For i = 0 To UBound(crr)
    
11.     With Sheets(crr(i))
    
12.         For j = 1 To .Range("A1").End(xlToRight).Column
    
13.             .Cells(2, j).Resize(UBound(brr)) = d(.Cells(1, j).Value)
    
14.         Next j
    
15.     End With
    
16. Next i
    
17. End Sub
    

复制代码

ldxhzy

1. Sub ldxhzy()
   
2.     Dim MySh As Worksheet
   
3.     'Dim MyD As New Dictionary 未用字典
   
4.     Dim MySou(), Tmp()
   
5.     Dim I As Long, J As Long, M As Long
   
6.     I = Worksheets("X").UsedRange.Rows.Count
   
7.     J = Worksheets("X").UsedRange.Columns.Count
   
8.     ReDim MySou(1 To I, 1 To J)
   
9.     MySou = Worksheets("X").Range(Cells(1, 1).Address, Cells(I, J).Address).Value
   
10.     ReDim Tmp(1 To UBound(MySou, 1) - 1)
    
11.     For Each MySh In ThisWorkbook.Worksheets
    
12.         If Not MySh.Name = "X" Then
    
13.             For I = 1 To MySh.UsedRange.Columns.Count
    
14.                 For J = 1 To UBound(MySou, 2)
    
15.                     If MySh.Cells(1, I) = MySou(1, J) Then
    
16.                         For M = 1 To UBound(Tmp)
    
17.                             Tmp(M) = MySou(M + 1, J)
    
18.                         Next M
    
19.                         MySh.Range(Cells(2, I).Address, Cells(M, I).Address) = Application.WorksheetFunction.Transpose(Tmp())
    
20.                         Exit For
    
21.                     End If
    
22.                 Next J
    
23.              Next I
    
24.         End If
    
25.     Next
    
26. End Sub
    

复制代码