多表合并，求助

xygz001 · 发表于 2024-2-17 16:48

多个表格，表格标题数据并不一致，有的表多一些项目。希望能够把所有表格按照标题合并成一个表格。

fzxba · 发表于 2024-2-17 17:56

本帖最后由 fzxba 于 2024-2-17 18:15 编辑

改一处.rar (41.08 KB, 下载次数: 25)

清风竹- · 发表于 2024-2-17 18:58

请测试一下。

ykcbf1100 · 发表于 2024-2-17 19:02

附件供参考。。。

ykcbf1100 · 发表于 2024-2-17 19:03

代码供参考。。。

Sub ykcbf() '//2024.2.17
Set Fso = CreateObject("scripting.filesystemobject")
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set ws = ThisWorkbook
Set sh = ws.Sheets("汇总")
p = ThisWorkbook.Path & ""
ReDim brr(1 To 10000, 1 To 100)
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)
r = .Cells(Rows.Count, 2).End(3).Row
c = .Cells.Find("*", SearchOrder:=xlByColumns, searchdirection:=xlPrevious).Column
arr = .[a1].Resize(r, c)
wb.Close False
End With
For j = 2 To UBound(arr, 2)
s = arr(1, j)
If Not d1.exists(s) Then
d1(s) = d1.Count + 1
End If
Next
For i = 2 To UBound(arr)
s = CStr(arr(i, 4))
If Not d.exists(s) Then
m = m + 1
d(s) = m
For j = 2 To UBound(arr, 2)
c = d1(arr(1, j))
brr(m, c) = arr(i, j)
Next
End If
Next
End If
End If
Next f
With sh
.Cells.Clear
.Columns(4).NumberFormatLocal = "@"
.[b1].Resize(1, d1.Count) = d1.keys
.[b1].Resize(1, d1.Count).Borders.LineStyle = 1
With .[b2].Resize(m, d1.Count)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
Set d = Nothing
MsgBox "OK！"
End Sub

复制代码

cai2532 · 发表于 2024-2-17 20:28

这个合并值的学习。

lushang2018 · 发表于 2024-2-17 22:42

Sub 测试()
Dim i%, j%, k%, m%, n%, arr, brr, crr, drr
Dim rng As Range, sht As Worksheet, wbk As Workbook
Dim dic As Object, key, keys, items
Set dic = CreateObject("scripting.dictionary")
ReDim brr(1 To 100, 1 To 20)
Dim path, 文件名
path = ThisWorkbook.path & ""
文件名 = Dir(path & "*.xls*")
Do While 文件名 <> ""
If 文件名 <> ThisWorkbook.Name Then
Set wbk = Workbooks.Open(path & 文件名)
For Each sht In wbk.Sheets
arr = sht.Range("B1").CurrentRegion
For j = 1 To UBound(arr, 2)
brr(1, j) = arr(1, j)
Next
For i = 2 To UBound(arr)
k = k + 1
For j = 1 To UBound(arr, 2)
brr(k + 1, j) = arr(i, j)
Next
Next
Next
wbk.Close False
End If
文件名 = Dir
Loop
ThisWorkbook.Sheets("sheet1").Range("A1").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

复制代码

yynrzwh · 发表于 2024-2-18 09:51

Py文件.rar (38.81 KB, 下载次数: 13)

x-xx-xx · 发表于 2024-2-18 10:33

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

[求助] 多表合并，求助