VBA实现按条件筛选后对应表头所有数据，求补充完善代码

dc201010

源数据表：

论坛找到的代码：

1. Sub lqt()
   
2.     Dim wb As Workbook
   
3.     Dim d As Object, d1 As Object
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     If Range("c65536").End(3).Row > 1 Then
   
6.         Range("a2:AW" & Range("c65536").End(3).Row).ClearContents
   
7.     End If
   
8.     arr = Sheets(1).UsedRange
   
9.     For j = 1 To UBound(arr, 2)
   
10.       d1(arr(1, j)) = j
    
11.     Next
    
12. Set wb = GetObject(ThisWorkbook.Path & "\收集表.xlsx")
    
13.     With Workbooks("收集表.xlsx")
    
14.         brr = .Sheets(1).UsedRange
    
15. ReDim crr(1 To UBound(brr), 1 To 48)
    
16.         For i = 3 To UBound(brr)
    
17.             If Len(brr(i, 1)) <> 0 Then
    
18.                 m = m + 1
    
19. For j = 1 To UBound(brr, 2)
    
20.                     If d1.Exists(brr(1, j)) Then
    
21.                     n = d1(brr(1, j))
    
22.                         crr(m, n) = brr(i, j)
    
23.                     End If
    
24.                 Next
    
25. '                brr(m, 3) = arr(i, 1): brr(m, 4) = arr(i, 2): brr(m, 5) = arr(i, 3)
    
26. '                brr(m, 6) = arr(i, 18): brr(m, 7) = arr(i, 16): brr(m, 8) = arr(i, 17): brr(m, 9) = arr(i, 19)
    
27. '                For j = 10 To 20
    
28. '                    brr(m, j) = arr(i, j - 5)
    
29. '                Next
    
30.             End If
    
31.         Next
    
32.         .Close 0
    
33.     End With
    
34.     Columns(3).NumberFormatLocal = "@"
    
35.     Columns(7).NumberFormatLocal = "@"
    
36.     [a2].Resize(m, 48) = crr
    
37.     Set wb = Nothing
    
38. End Sub
    

复制代码

当前代码实现效果：

想要实现的效果：

问题说明：

附件：
对应表头数据.rar (39.96 KB, 下载次数: 12)

2020-3-14 15:47 上传

点击文件名下载附件

dc201010

自己顶一下吧！

dc201010

继续等大神现身说法！！！

1016373263

源数据在哪？不知道你说的在哪操作

dc201010

1016373263 发表于 2020-3-15 17:22
源数据在哪？不知道你说的在哪操作

请看附件！！！