在Excel工作薄的多个工作中，提取D列数据后，将提取的数据汇总到一个工作表中。

jscsj

在Excel工作薄的多个工作中，提取D列数据后，将提取的数据汇总到一个工作表中。

我想把工作薄中多个工作表中的D列（检索内容/检索词）提取出来，做成一个新的工作表。
新的工作表每一列的项目名称就是对应的工作的名称。
再把每列的空白单元格去掉（使有内容的单元格连续排列）。

3190496160

Sub hebing()
Dim ar As Variant
Dim br()
ReDim br(1 To 100000, 1 To Sheets.Count - 1)
For Each sh In Sheets
    If sh.Name <> "汇总" Then
        y = y + 1
        r = sh.Cells(Rows.Count, 4).End(xlUp).Row
        ar = sh.Range("d1:d" & r)
        br(1, y) = sh.Name
        n = 1
        For i = 2 To UBound(ar)
            If ar(i, 1) <> "" Then
                n = n + 1
                br(n, y) = ar(i, 1)
            End If
        Next i
    End If
Next sh
[a1].CurrentRegion = Empty
[a1].Resize(UBound(br), UBound(br, 2)) = br
End Sub

3190496160

searchstep_T1_0801.rar (98.72 KB, 下载次数: 7)

2024-8-2 12:31 上传

点击文件名下载附件

ykcbf1100

没见到多工作簿啊，楼主是不是把工作簿和工作表搞混了。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.2
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总表")
   
4.     ReDim brr(1 To 1000, 1 To 100)
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             n = n + 1
   
8.             m = 1
   
9.             brr(1, n) = sht.Name
   
10.             With sht
    
11.                 r = .Cells(Rows.Count, 4).End(3).Row
    
12.                 arr = .[d1].Resize(r, 1)
    
13.                 For i = 2 To UBound(arr)
    
14.                     If arr(i, 1) <> Empty Then
    
15.                         m = m + 1
    
16.                         brr(m, n) = arr(i, 1)
    
17.                     End If
    
18.                 Next
    
19.             End With
    
20.             Max = IIf(Max < m, m, Max)
    
21.         End If
    
22.     Next
    
23.     With sh
    
24.         .Cells.Clear
    
25.         .[a1].Resize(Max, n) = brr
    
26.      '   .[a1].Resize(Max, n).EntireColumn.AutoFit
    
27.     End With
    
28.     Application.ScreenUpdating = False
    
29.     MsgBox "OK！"
    
30. End Sub
    
31. 
    

复制代码

jscsj

3190496160 发表于 2024-8-2 12:31

非常感谢！完全满足我的要求。

jscsj

ykcbf1100 发表于 2024-8-2 12:55
参与一下。。。

感谢参与！我也试了，代码能满足我的要求！
非常感谢！