有没有高手帮忙将表1中的数据填充到表2，十分感谢！

梦无痕1981

有没有高手帮忙将表1中的数据依次填充到表2，形成表2的布局样子，非常感谢！！！

小花鹿

这种转置比较复杂                                                                                                

LMY123

没看懂，每个人行数不一样，有9行，11行，12行

梦无痕1981

LMY123 发表于 2018-7-4 10:48
没看懂，每个人行数不一样，有9行，11行，12行

行数可以统一的，都统一为12行也没问题，谢谢！

梦无痕1981

高手帮忙江湖救急啊 谢谢！

LMY123

梦无痕1981 发表于 2018-7-4 15:05
高手帮忙江湖救急啊 谢谢！

1. Sub 转置()
   
2.     Cells.Clear
   
3.     Cells.UnMerge
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Sheet5.Activate ''结果表
   
7.     Arr = Sheet1.[A1].CurrentRegion ''数据源
   
8.     For i = 2 To UBound(Arr)
   
9.         x = Arr(i, 2) '''
   
10.         y = Arr(i, 1) '''
    
11.         d1(y) = ""
    
12.             If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
13.         d(x)(y) = d(x)(y) & "," & Arr(i, 3) & "," & Arr(i, 4) & "," & Arr(i, 5) & "," & Arr(i, 6) & "," & Arr(i, 7)
    
14.     Next
    
15.     k = d.Keys
    
16.     t = d.items
    
17.     k1 = d1.Keys
    
18.     For r = 1 To d.Count
    
19.         Cells((r - 1) * 25 + 5, 1).Resize(12, 1) = k(r - 1) '''
    
20.     Next
    
21.     For c = 1 To d1.Count
    
22.         Cells(1, (c - 1) * 9 + 2).Resize(1, 9) = k1(c - 1)  ''
    
23.     Next
    
24.     N = 5
    
25.     With Sheets("Sheet3") '''结果表
    
26.         Arr = .UsedRange
    
27.         For i = 5 To UBound(Arr) Step 25 '''///
    
28.             If d.exists(Arr(i, 1)) Then ''
    
29.                 For j = 2 To UBound(Arr, 2) - 1 Step 9
    
30.                     If d(Arr(i, 1)).exists(Arr(1, j)) Then ''''////
    
31.                         SS = Split(Mid(d(Arr(i, 1))(Arr(1, j)), 2), ",") '''///
    
32.                         For r = 0 To UBound(SS) / N
    
33.                             For M = 1 To N
    
34.                                 If UBound(SS) = 0 Then
    
35.                                     Arr(i, j + M - 1) = "'" & Split(Mid(d(Arr(i, 1))(Arr(1, j)), 2), ",")(M - 1) '''///
    
36.                                 Else
    
37.                                     Arr(i + r, j + M - 1) = "'" & Split(Mid(d(Arr(i, 1))(Arr(1, j)), 2), ",")(r * N + M - 1)  '''///
    
38.                                 End If
    
39.                             Next
    
40.                         Next
    
41.                     End If
    
42.                 Next j
    
43.             End If
    
44.         Next i
    
45.         .UsedRange = Arr
    
46.     End With
    
47.     Application.ScreenUpdating = False
    
48.     Application.DisplayAlerts = False
    
49.     For j = 2 To UBound(Arr, 2) Step 9
    
50.         Range(Cells(1, j), Cells(1, j + 8)).Merge
    
51.     Next
    
52.     Application.ScreenUpdating = True
    
53.     Application.DisplayAlerts = True
    
54.     Cells.EntireColumn.AutoFit  '
    
55.     Cells.HorizontalAlignment = xlCenter
    
56.     d.RemoveAll
    
57.     d1.RemoveAll
    
58.     Erase Arr '
    
59. End Sub

复制代码

梦无痕1981

LMY123 发表于 2018-7-5 15:29

非常感谢帮助，可是运行时总提示错误，帮忙看看是怎么回事呢，多谢！！

梦无痕1981

LMY123 发表于 2018-7-5 15:29

改动了一下，可以成功转置了，但是会清除表2中的格式，可不可以帮忙优化一下，不改变表2 原来的格式呢？谢谢

。。。
刚又发现一个问题，就是已经修改好可以转置了，但是稍后再试，又会提示错误，不知道是咋回事

梦无痕1981

梦无痕1981 发表于 2018-7-10 13:57
改动了一下，可以成功转置了，但是会清除表2中的格式，可不可以帮忙优化一下，不改变表2 原来的格式呢？ ...

刚又发现一个问题，就是已经修改好可以转置了，但是稍后再试，又会提示错误，不知道是咋回事

梦无痕1981

LMY123 发表于 2018-7-5 15:29

请帮忙给看下，优化下代码，万分感谢！！！