[已解决]请问如何用VBA，将“汇总”表里的内容按照AN列的名称复制到对应的工作表里，谢谢。

新一

请问如何用VBA，将“汇总”表里的内容按照AN列的名称复制到对应的工作表里，谢谢。

最佳答案

月排行榜 / 总排行榜

金樽空对月

2022-4-21 16:44

1. Sub mytest()
   
2. Dim x%, n%, j%, k%, ar, br(1 To 20000, 1 To 39)
   
3. j = Sheets("汇总").Range("an100000").End(3).Row
   
4. ar = Sheets("汇总").Range("a2:an" & j)
   
5. For x = 4 To Sheets.Count
   
6.     For y = 1 To UBound(ar)
   
7.         If Sheets(x).Name = ar(y, 40) Then
   
8.             n = n + 1
   
9.             For k = 1 To 39
   
10.                 br(n, k) = ar(y, k)
    
11.             Next k
    
12.         End If
    
13.     Next y
    
14.     Sheets(x).Range("b100000").End(3).Offset(1, 0).Resize(n, 39) = br
    
15.     Erase br: n = 0
    
16. Next x
    
17. End Sub

复制代码

跳转到最佳答案楼层

新一

Sub Macro1()
Dim arr, brr, d, i&, j%, y&
Set d = CreateObject("scripting.dictionary")
Sheets("总表").Activate
arr = Range("a2").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 8)
y = UBound(arr, 2)
For j = 6 To Sheets.Count
    Sheets(j).UsedRange.Offset(2, 0).ClearContents
Next
For i = 3 To UBound(arr)
    If arr(i, 9) = "锻压" Then d(arr(i, 1)) = d(arr(i, 1)) & " " & i
Next
a = d.keys: b = d.items
For i = 0 To d.Count - 1
    x = Split(b(i))
    z = Day(a(i))
    For j = 1 To UBound(x)
        brr(j, 1) = a(i)
        brr(j, 2) = arr(x(j), 8)
        brr(j, 3) = arr(x(j), 3)
        brr(j, 4) = arr(x(j), 4)
        brr(j, 5) = arr(x(j), 5)
        brr(j, 6) = arr(x(j), 6)
        brr(j, 7) = arr(x(j), 7)
    Next
    Sheets("" & z).Cells(3, 1).Resize(UBound(x), UBound(brr, 2)) = brr
Next
End Sub
像这样的代码需要怎么修改，才可以是附件的效果。

金樽空对月

1. Sub mytest()
   
2. Dim x%, n%, j%, k%, ar, br(1 To 20000, 1 To 39)
   
3. j = Sheets("汇总").Range("an100000").End(3).Row
   
4. ar = Sheets("汇总").Range("a2:an" & j)
   
5. For x = 4 To Sheets.Count
   
6.     For y = 1 To UBound(ar)
   
7.         If Sheets(x).Name = ar(y, 40) Then
   
8.             n = n + 1
   
9.             For k = 1 To 39
   
10.                 br(n, k) = ar(y, k)
    
11.             Next k
    
12.         End If
    
13.     Next y
    
14.     Sheets(x).Range("b100000").End(3).Offset(1, 0).Resize(n, 39) = br
    
15.     Erase br: n = 0
    
16. Next x
    
17. End Sub

复制代码

hasyh2008

这个试试！！！！！！！

hasyh2008

Sub 删除表格()
  Application.ScreenUpdating = False '//关闭屏幕刷新
  Application.DisplayAlerts = False '//关闭系统提示
  Dim Sh As Worksheet
  For Each Sh In Worksheets
    If Sh.CodeName <> Sheet1.CodeName And Sh.CodeName <> Sheet2.CodeName Then Sh.Delete
  Next Sh
  Application.ScreenUpdating = True '//恢复屏幕刷新
  Application.DisplayAlerts = True '//恢复系统提示
End Sub

Sub 生成表格()
  Application.ScreenUpdating = False '//关闭屏幕刷新
  Application.DisplayAlerts = False '//关闭系统提示
  Application.EnableEvents = False  '//禁止触发其他事件
  Application.StatusBar = False   '关闭系统状态条
  Dim Dic, K%, I%, Arr(), X%, Y%, Col%, 项目名称(), Brr(), Crr()
  Dim Sh As Worksheet
  Call 删除表格
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Sheet1.Range("A1").CurrentRegion
  Y = UBound(Arr, 2)
  For X = 2 To UBound(Arr)
    Dic(Arr(X, Y)) = ""
  Next X
  项目名称 = Dic.keys
  For K = 0 To UBound(项目名称)
    I = 1
    Brr = Sheet1.Range("A1:AM1")
    Crr = Application.Transpose(Brr)
    For X = 2 To UBound(Arr)
      If Arr(X, Y) = 项目名称(K) Then
        I = I + 1
        For Col = 1 To 39
          ReDim Preserve Crr(1 To 39, 1 To I)
          Crr(Col, I) = Arr(X, Col)
        Next Col
      End If
    Next X
    Brr = Application.Transpose(Crr)
    Set Sh = Worksheets.Add(after:=Sheets(Worksheets.Count))
    Sh.Range("A1").Resize(I, 39) = Brr
    Sh.Name = 项目名称(K)
  Next K
  Sheet2.Activate
  Call CreateSheetsIndex
  Application.StatusBar = True   '恢复系统状态条
  Application.EnableEvents = True  '//恢复触发其他事件
  Application.ScreenUpdating = True '//恢复屏幕刷新
  Application.DisplayAlerts = True '//恢复系统提示
End Sub

新一

谢谢大神们的帮助，么么达