请教数据排列样式转换

IE_Crayon

1. Option Explicit
   
2. 
   
3. Sub byz_demo()
   
4. 
   
5.     Dim i As Long, j As Long, k As Long
   
6.     Dim ws0 As Worksheet, ws As Worksheet
   
7.    
   
8.     j = 2
   
9.     Set ws0 = Worksheets("sheet1"): Set ws = Worksheets("sheet2")
   
10.    
    
11.     For i = 2 To ws0.Cells(ws0.Rows.Count, 1).End(xlUp).Row + 1
    
12.    
    
13.         If ws0.Cells(i, 4).Value <> "忽略" Then
    
14.             
    
15.             For k = 2 To 4
    
16.                 If Trim(ws.Cells(1, k).Value) = Trim(ws0.Cells(i, 2).Value) Then
    
17.                     If j > 2 And Trim(ws0.Cells(i, 1).Value) = Trim(ws.Cells(j - 1, 1).Value) Then
    
18.                     j = j - 1
    
19.                     End If
    
20.                     ws.Cells(j, 1) = ws0.Cells(i, 1)
    
21.                     ws.Cells(j, k) = ws0.Cells(i, 3)
    
22.                     j = j + 1
    
23.                 End If
    
24.             Next k
    
25.         End If
    
26.     Next i
    
27. 
    
28. End Sub

复制代码

zhangcheng6688

借楼学习一下字典
Sub test()
arr = Sheets("sheet1").[a1].CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
   If arr(i, 4) <> "忽略" Then
      If Not dic.exists(arr(i, 1)) Then
         Set dic(arr(i, 1)) = CreateObject("scripting.dictionary")
      End If
      dic(arr(i, 1))(arr(i, 2)) = arr(i, 3)
   End If
Next
With Sheets("sheet2")
   brr = .Range("a1:e10000")
   m = 1
   For Each k In dic.keys
      m = m + 1
      brr(m, 1) = k
      For i = 2 To UBound(brr, 2)
         If dic(k).exists(brr(1, i)) Then
            brr(m, i) = dic(k)(brr(1, i))
         Else
            brr(m, i) = ""
         End If
      Next
   Next
   .[a1].Resize(m, UBound(brr, 2)) = brr
End With
Set dic = Nothing
End Sub

翁知江安

Sub test()
Dim i, j As Integer
Dim ar, br, cr As Variant
Dim d1, d2, d3 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
    d1(ar(i, 2)) = "": d2(ar(i, 1)) = ""
    d3(ar(i, 1) & ar(i, 2)) = ar(i, 3)
Next
Sheet2.[b1].Resize(1, d1.Count) = d1.keys
Sheet2.[a2].Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.keys)
br = Sheet2.[a1].CurrentRegion
ReDim cr(1 To d2.Count, 1 To d1.Count)
For i = 2 To UBound(br)
    For j = 2 To d1.Count + 1
    cr(i - 1, j - 1) = d3(br(i, 1) & br(1, j))
    Next
Next
Sheet2.[b2].Resize(1000, 50).ClearContents
Sheet2.[b2].Resize(UBound(cr), UBound(cr, 2)) = cr
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正