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

jscsj · 发表于 2024-8-2 11:45

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

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

3190496160 · 发表于 2024-8-2 12:30

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 · 发表于 2024-8-2 12:31

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

ykcbf1100 · 发表于 2024-8-2 12:43

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

ykcbf1100 · 发表于 2024-8-2 12:55

附件供参考。。。

ykcbf1100 · 发表于 2024-8-2 12:55

参与一下。。。

Sub ykcbf() '//2024.8.2
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("汇总表")
ReDim brr(1 To 1000, 1 To 100)
For Each sht In Sheets
If sht.Name <> sh.Name Then
n = n + 1
m = 1
brr(1, n) = sht.Name
With sht
r = .Cells(Rows.Count, 4).End(3).Row
arr = .[d1].Resize(r, 1)
For i = 2 To UBound(arr)
If arr(i, 1) <> Empty Then
m = m + 1
brr(m, n) = arr(i, 1)
End If
Next
End With
Max = IIf(Max < m, m, Max)
End If
Next
With sh
.Cells.Clear
.[a1].Resize(Max, n) = brr
' .[a1].Resize(Max, n).EntireColumn.AutoFit
End With
Application.ScreenUpdating = False
MsgBox "OK！"
End Sub

复制代码

jscsj · 发表于 2024-8-2 17:39

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

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

jscsj · 发表于 2024-8-2 17:43

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

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

		自动登录	找回密码
密码			免费注册

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

评分