不同形式的工作表汇总到一个工作表里面

Lisianthus1 · 发表于 2024-5-21 10:00

有几个内容完全不同的订单导出表，想要提取其中几项数据，并且自动汇总到一个工作表里面，各位大神有什么代码吗？本人也在学VBA，但是刚入门小白，实在心有余而力不足。

附件01-05是原始表格（需要提取的列已经标记了黄色），汇总表里面是需要数据的标题 1716256770781(1).jpg

VBA.zip (78.39 KB, 下载次数: 9)

limonet · 发表于 2024-5-21 10:08

思路do while+open，因为不规范，只能打开再用数组或SQL。

ykcbf1100 · 发表于 2024-5-21 10:08

你这数据也太不规范了吧，列号不同也就算了，标题行不同也就算了，居然字段名也会不同。
请楼主至少把需要汇总的字段搞成一样了，不然，不好下手。

Lisianthus1 · 发表于 2024-5-21 10:20

ykcbf1100 发表于 2024-5-21 10:08
你这数据也太不规范了吧，列号不同也就算了，标题行不同也就算了，居然字段名也会不同。
请楼主至少把需要 ...

好的马上处理！

Lisianthus1 · 发表于 2024-5-21 10:24

是我考虑不周，已经重新修改了原始数据需要提取的标题，与汇总表内一致，希望各位大神多多指点

ykcbf1100 · 发表于 2024-5-21 10:41

附件供参考。。。

ykcbf1100 · 发表于 2024-5-21 10:42

参与一下。。。

Sub ykcbf() '//2024.5.21
Set fso = CreateObject("scripting.filesystemobject")
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("Sheet1")
With sh
c = .UsedRange.Columns.Count
For j = 1 To c
s = .Cells(1, j)
d(s) = j
Next
End With
ReDim brr(1 To 10000, 1 To c)
p = ThisWorkbook.Path & ""
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = fso.GetBaseName(f)
Set wb = Workbooks.Open(f, 0)
With wb.Sheets(1)
arr = .UsedRange
bt = .UsedRange.Find("时间").Row
wb.Close False
End With
For i = bt + 1 To UBound(arr)
If arr(i, 1) <> Empty Then
m = m + 1
For j = 1 To UBound(arr, 2)
s = arr(bt, j)
If d.exists(s) Then
brr(m, d(s)) = arr(i, j)
End If
Next
End If
Next
End If
End If
Next f
With sh
.UsedRange.Offset(1).Clear
.[a1].Resize(1, c).Interior.Color = 49407
With .[a2].Resize(m, 5)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

Lisianthus1 · 发表于 2024-5-21 11:29

ykcbf1100 发表于 2024-5-21 10:41
附件供参考。。。

感谢！！！

Lisianthus1 · 发表于 2024-5-21 11:29

ykcbf1100 发表于 2024-5-21 10:42
参与一下。。。

好的我认真研究一下太感谢了

baofa2 · 发表于 2024-5-21 11:49

Option Explicit
Sub test1() '
Dim strPath As String, strFile As String
Dim results, data, pos() As Long, dict As Object, target As Range
Dim i As Long, j As Long, rowSize As Long, x As Long, y As Long
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = TextCompare '标题中有大写的 SKU 小写的 sku 这里不区分大小写
rowSize = 1
With Range("A1").CurrentRegion
.Offset(rowSize).Clear 'Contents
data = .Rows(rowSize).Value
results = .Resize(50000)
End With
DoApp False
For j = 1 To UBound(data, 2)
If Len(data(rowSize, j)) Then dict.Add data(rowSize, j), j
Next
strPath = ThisWorkbook.Path & "\"
strFile = Dir(strPath & "*.xls*")
While Len(strFile)
If strPath & strFile <> ThisWorkbook.FullName Then
With Workbooks.Open(strPath & strFile, 0)
With .Worksheets(1)
Set target = .Cells.Find("时间", , xlValues, , xlByRows, xlPrevious)
If Not target Is Nothing Then
y = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
x = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
With .Range("A1", .Cells(y, x))
data = Intersect(.Offset(0), .Offset(target.Row - 1)).Value
x = 0
For j = 1 To UBound(data, 2)
If Len(data(1, j)) Then
If dict.Exists(data(1, j)) Then
x = x + 1
ReDim Preserve pos(1, 1 To x)
pos(0, x) = j
pos(1, x) = dict(data(1, j))
End If
End If
Next
If x Then
For i = 2 To UBound(data)
rowSize = rowSize + 1
For j = 1 To UBound(results, 2) '本是 1 to x ，但 03.xlsx 文件中 SKU 重复了，最后一个舍弃不汇总
results(rowSize, pos(1, j)) = data(i, pos(0, j))
Next
Next
End If
End With
End If
End With
.Close False
End With
End If
strFile = Dir
Wend
With Range("A1").Resize(rowSize, UBound(results, 2))
.Borders.Weight = xlHairline
.HorizontalAlignment = xlCenter
.Value = results
End With
Set target = Nothing
Set dict = Nothing
DoApp
Beep
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function

复制代码

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

[求助] 不同形式的工作表汇总到一个工作表里面