汇总多个表格数据

yanglinzi · 发表于 2024-4-23 20:44

参与一下。。

yanglinzi · 发表于 2024-4-23 20:45

Sub 汇总()
Dim arr, j, r, c
c = 21
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ReDim arr(1 To c)
Set fso = CreateObject("scripting.filesystemobject")
p = ThisWorkbook.Path & "\测试"
For Each f In fso.getfolder(p).Files
r = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
Set wb = Workbooks.Open(f)
Set sht = wb.Sheets(1)
With sht
arr(1) = r - 1
arr(2) = .[i3]
arr(3) = .[i4]
arr(4) = .[c5]
arr(5) = .[i5]
arr(6) = .[i6]
arr(7) = .[a9]
arr(8) = .[e9]
arr(9) = .[i9]
For j = 1 To 12
arr(j + 9) = .Cells(12, j)
Next
End With
wb.Close False
Sheet1.Cells(r + 1, 1).Resize(1, c) = arr
Next
Sheet1.Range("b:b,d:e,h:h").WrapText = True
Sheet1.Range("c:c,f:f").NumberFormatLocal = "yyyy-m-d"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

复制代码

baofa2 · 发表于 2024-4-24 15:21

Sub test1() '参与练习一下 https://club.excelhome.net/thread-1690486-1-1.html
Dim results(), ar, br(1), cel As Range, Item_
Dim i As Long, j As Long, pos As Long, cnt As Long
Dim Conn As Object, re As Object, dict As Object
Dim SQL As String, s As String, p As String, f As String
Set dict = CreateObject("Scripting.Dictionary")
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.Pattern = "(\D+)(\d+)(\D+)(\d+)"
cnt = 1
ar = Split("I3 I4 C5 I5 I6 A9 E9 I9 A12:L12")
For Each Item_ In ar
For Each cel In Range(Item_)
i = 0
s = cel.Address(, , xlR1C1)
For j = 4 To 2 Step -2
br(i) = re.Replace(s, "$" & j) - 1
i = i + 1
Next
cnt = cnt + 1
dict.Add Join(br, "|"), cnt
Next
Next
ReDim results(1 To 5000, 1 To cnt)
Set re = Nothing
cnt = 0
ActiveSheet.UsedRange.Offset(2).ClearContents
Application.ScreenUpdating = False
Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\测试\"
f = Dir(p & "*.xls*")
Do
If f <> ThisWorkbook.Name Then
cnt = cnt + 1
results(cnt, 1) = cnt
SQL = "SELECT * FROM [Excel 12.0;HDR=NO;IMEX=1;Database=" & p & f & "].[$A1:M12]"
ar = Conn.Execute(SQL).GetRows
For j = 0 To UBound(ar, 2)
For i = 0 To UBound(ar)
s = i & "|" & j
If dict.Exists(s) Then
pos = dict(s)
results(cnt, pos) = ar(i, j)
End If
Next
Next
End If
f = Dir
Loop While f <> ""
Range("A3").Resize(cnt, UBound(results, 2)) = results
Conn.Close
Set Conn = Nothing
Set dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

ykcbf1100 · 发表于 2024-4-24 16:54

参与一下，是有点麻烦的。

ykcbf1100 · 发表于 2024-4-24 16:55

参与一下。。。

Sub ykcbf() '//2024.4.24
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 = 2 To c
s = .Cells(2, j)
d(s) = j
Next
End With
p = ThisWorkbook.Path & "\测试"
a = [{"G3","G4","A5","G5","G6","A8","E8","H8"}]
b = [{"i3","i4","c5","i5","i6","A9","e9","i9"}]
ReDim brr(1 To 1000, 1 To c)
On Error Resume Next
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls*" Then
fn = fso.GetBaseName(f)
m = m + 1
brr(m, 1) = m
Set wb = Workbooks.Open(f, 0)
With wb.Sheets(1)
arr = .UsedRange
For x = 1 To UBound(a)
s = Trim(.Range(a(x)).Value)
If d.exists(s) Then
brr(m, d(s)) = .Range(b(x)).Value
End If
Next
End With
wb.Close False
For j = 1 To UBound(arr, 2)
s = arr(11, j)
If d.exists(s) Then
brr(m, d(s)) = arr(12, j)
End If
Next
End If
Next f
With sh
.UsedRange.Offset(2).Clear
With .[a3].Resize(m, c)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

baofa2 · 发表于 2024-4-24 17:54

Sub test1() '改进一下，通用Excel和WPS，另添加一些格式
Dim results(), ar, br(1), cel As Range, Item_
Dim i As Long, j As Long, pos As Long, cnt As Long
Dim Conn As Object, re As Object, dict As Object, Flag As Boolean
Dim strConn As String, SQL As String, s As String, p As String, f As String
Set Conn = CreateObject("ADODB.Connection")
Set dict = CreateObject("Scripting.Dictionary")
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.Pattern = "(\D+)(\d+)(\D+)(\d+)"
ar = Split("I3 I4 C5 I5 I6 A9 E9 I9 A12:L12")
For Each Item_ In ar
For Each cel In Range(Item_)
s = cel.Address(, , xlR1C1)
For j = 4 To 2 Step -2
br(-CInt(j = 2)) = re.Replace(s, "$" & j) - 1
Next
dict.Add Join(br, "|"), dict.Count + 2
Next
Next
ReDim results(1 To 2345, 1 To dict.Count + 1)
Set re = Nothing
ActiveSheet.UsedRange.Offset(2).Clear 'Contents
Application.ScreenUpdating = False
Flag = InStr(Application.Path, "WPS") > 0
s = "Excel 12.0;HDR=NO;IMEX=1;Database="
If Application.Version < 12 Or Flag Then
s = Replace(s, "12.0", "8.0")
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO;IMEX=1';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO;IMEX=1';Data Source="
End If
'Conn.Open strConn & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\测试\"
SQL = "SELECT * FROM [" & s & p & "[.f]].[$A1:M12]"
f = Dir(p & "*.xls*")
Do
If f <> ThisWorkbook.Name Then
cnt = cnt + 1
results(cnt, 1) = cnt
If cnt = 1 Then Conn.Open strConn & p & f
ar = Conn.Execute(Replace(SQL, "[.f]", f)).GetRows
For j = 0 To UBound(ar, 2)
For i = 0 To UBound(ar)
s = i & "|" & j
If dict.Exists(s) Then
pos = dict(s)
results(cnt, pos) = ar(i, j)
End If
Next
Next
End If
f = Dir
Loop While f <> ""
Range("A3").Resize(cnt, UBound(results, 2)) = results
With Range("A1").CurrentRegion
With Intersect(.Offset(0), .Offset(2))
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.Font.Size = 9
End With
End With
Conn.Close
Set Conn = Nothing
Set dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

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

[求助] 汇总多个表格数据

评分

评分

评分