[已解决]如何用VBA将表一，表二，表三的数据，在总表里显视出来，谢谢

新一

如何用VBA将表一，表二，表三的数据，在总表里显视出来，谢谢。如我的附件。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-19 19:59

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr(1 To 16, 1 To 8)
   
3. Dim n&, k%, j&, i&, s&
   
4. Range("a3:h65536").ClearContents
   
5. n = 3
   
6. For k = 1 To 2
   
7.     arr = Sheets(k).UsedRange
   
8.     For i = 2 To UBound(arr)
   
9.         If InStr(arr(i, 1), "对应单号") And Len(arr(i, 1)) > 5 Then
   
10.             brr = Sheets(k).Cells(i, 1).Resize(16, 8)
    
11.             y = Val(brr(1, 6)): m = Val(brr(1, 7)): r = Val(brr(1, 8))
    
12.             rq = DateSerial(y, m, r)
    
13.             dh = Mid(brr(1, 1), 6)
    
14.             mc = Mid(brr(2, 1), 4)
    
15.             s = 0
    
16.             For j = 4 To UBound(brr)
    
17.                 If brr(j, 2) <> "" Then
    
18.                     s = s + 1
    
19.                     crr(s, 1) = rq
    
20.                     crr(s, 2) = dh
    
21.                     crr(s, 3) = mc
    
22.                     crr(s, 4) = brr(j, 2)
    
23.                     crr(s, 5) = brr(j, 5)
    
24.                     crr(s, 6) = brr(j, 6)
    
25.                     crr(s, 7) = brr(j, 7)
    
26.                     crr(s, 8) = brr(j, 3)
    
27.                 End If
    
28.             Next
    
29.             Cells(n, 1).Resize(s, UBound(crr, 2)) = crr
    
30.             n = n + s
    
31.         End If
    
32.     Next
    
33. Next
    
34. Sheet3.Range("a3:h" & Sheet3.Range("a65536").End(xlUp).Row).Copy Cells(n, 1)
    
35. End Sub
    

复制代码

dsmch

………………

新一

dsmch 发表于 2014-3-19 19:59
………………

，谢谢帮助，非常感激........

新一

dsmch 发表于 2014-3-19 19:59
………………

如果我想将每一个员工都分别，在每一个工作表中列出明细，可否做到这种效果。谢谢。比如，赵二员工，我就要插入一个工作表，然后，将工作表命名为赵二，在赵二表中，就会显视赵二个人的明细。

dsmch

新一 发表于 2014-3-19 20:20
如果我想将每一个员工都分别，在每一个工作表中列出明细，可否做到这种效果。谢谢。比如，赵二员工，我就 ...

可以做到，建议另开新帖并模拟一下结果，链接一下新贴地址。

新一

dsmch 发表于 2014-3-19 20:27
可以做到，建议另开新帖并模拟一下结果，链接一下新贴地址。

附件已上传，排序时，可否按时间来排一下，因为我是一个一个的复制到每个人的表中，所以只能会用自动筛选的功能。谢谢帮助，非常感激。

dsmch

1. Sub Macro2()
   
2. On Error Resume Next
   
3. Dim arr, d, i&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. For i = Sheets.Count To 5 Step -1
   
9.     Sheets(i).Delete
   
10. Next
    
11. For i = 3 To UBound(arr)
    
12.     If Not d.exists(arr(i, 8)) Then
    
13.         d(arr(i, 8)) = ""
    
14.         If Sheets("" & arr(i, 8)) Is Nothing Then
    
15.             Sheets("总表").[h2].AutoFilter Field:=8, Criteria1:=arr(i, 8)
    
16.             With Sheets.Add(after:=Sheets(Sheets.Count))
    
17.                 ActiveSheet.Name = arr(i, 8)
    
18.                 Sheets("总表").[a:h].Copy Range("a1")
    
19.                 Columns.AutoFit
    
20.             End With
    
21.         End If
    
22.     End If
    
23.     Sheets("总表").ShowAllData
    
24. Next
    
25. Sheets("总表").Activate
    
26. Application.DisplayAlerts = True
    
27. Application.ScreenUpdating = True
    
28. End Sub
    

复制代码

dsmch

………………

锋速vba

强~~，学习iang