难题，帮忙修改一下，以A列为所列数据为基础，汇总余额表的H-K列数据相应数据

excel学习123 · 发表于 2017-3-6 14:49

zhouxiao 发表于 2017-3-6 14:08
一共有多少工作簿需要合并?

老师能弄好吗？在线等

excel学习123 · 发表于 2017-3-6 14:50

liulang0808 发表于 2017-3-6 13:50
看不明白，建议结合附件内容，做个模拟实例进行说明下，具体要干什么，怎么做

老师能弄好吗？在线等

chxw68 · 发表于 2017-3-6 15:45

Sub test()
Dim r%, i%
Dim arr, brr
Dim wb As Workbook
Dim ws As Worksheet
Dim mypath$, myname$
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("汇总")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:a" & r)
For i = 1 To UBound(arr)
d(arr(i, 1)) = i
Next
End With
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xls")
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
ReDim brr(1 To d.Count, 1 To 4)
wjm = Split(myname, ".")(0)
Set wb = GetObject(mypath & myname)
With wb
With .Worksheets(1)
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("d2:k" & r)
For i = 1 To UBound(arr)
xm = Trim(arr(i, 1))
If d.exists(xm) Then
m = d(xm)
For j = 1 To 4
brr(m, j) = arr(i, j + 4)
Next
End If
Next
End With
.Close False
End With
d1(wjm) = brr
End If
myname = Dir()
Loop
With Worksheets("汇总")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("b2").Resize(r - 1, .Columns.Count - 1).Clear
n = 2
For Each aa In d1.keys
brr = d1(aa)
With .Cells(2, n)
.Value = aa
.Resize(1, 4).Merge
End With
.Cells(3, n).Resize(1, 4) = Array("本期发" & vbLf & "生借方", "本期发" & vbLf & "生贷方", "期末余" & vbLf & "额借方", "期末余" & vbLf & "额贷方")
.Cells(4, n).Resize(UBound(brr), 4) = brr
n = n + 4
Next
n = n - 1
.Range("a2").Resize(r - 1, n).Borders.LineStyle = xlContinuous
.Range("b4").Resize(r - 3, n - 1).NumberFormatLocal = "0.00"
.Range("a2").Resize(1, n).EntireColumn.AutoFit
With .Range("a1").Resize(3, n)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2017-3-6 15:47

根据楼主模拟结果写的代码，不知道结果对不对。

zhouxiao · 发表于 2017-3-6 15:52

我是按照我的想法在你的代码基础上改的,供参考

Sub lsc()
Dim wk As Workbook
Sheet2.Range("A2:L" & Sheet2.Range("A65536").End(3).Row).ClearContents
Application.ScreenUpdating = False
Set Fso = CreateObject("scripting.filesystemobject")
Set ff = Fso.getfolder(ThisWorkbook.Path)
lrow1 = Workbooks("多表按条件汇总").Sheets(2).Range("A65536").End(3).Row + 1
For Each f In ff.Files
If f.Name <> ThisWorkbook.Name Then
Set wk = Workbooks.Open(f)
With Sheets(1)
lrow = .Range("A65536").End(3).Row
.Range("A2:K" & lrow).Copy Workbooks("多表按条件汇总").Sheets(2).Cells(lrow1, 2)
If lrow1 > 2 Then
lrow = lrow + lrow1 - 2
End If
Workbooks("多表按条件汇总").Sheets(2).Range("A" & lrow1 & ":A" & lrow) = WorksheetFunction.Substitute(wk.Name, ".xls", "")
lrow1 = lrow + 1
End With
Workbooks(Split(f, "")(UBound(Split(f, "")))).Close False
End If
Next
Application.ScreenUpdating = True
End Sub

复制代码

zhouxiao · 发表于 2017-3-6 15:53

附件供参考

多表按条件汇总.rar (40.36 KB, 下载次数: 14)

zhouxiao · 发表于 2017-3-6 15:55

源数据合并以后,用数据透视表汇总的

excel学习123 · 发表于 2017-3-6 15:59

zhouxiao 发表于 2017-3-6 15:53
附件供参考

谢谢你但是和我说的不太一致 lrow1 = Workbooks("多表按条件汇总").Sheets(2).Range("A65536").End(3).Row + 1 不能用

乐乐2006201505 · 发表于 2017-3-6 20:58

本帖最后由乐乐2006201505 于 2017-3-6 21:24 编辑

已经在原代码基础上做出来了，所以也凑个热闹，贻笑大方。不足之处，望各位老师批评指正，不胜感激。

乐乐2006201505 · 发表于 2017-3-6 21:00

本帖最后由乐乐2006201505 于 2017-3-6 21:36 编辑

excel学习123 发表于 2017-3-6 15:59
谢谢你但是和我说的不太一致 lrow1 = Workbooks("多表按条件汇总").Sheets(2).Range("A65536").End(3) ...

lrow1 = Workbooks("多表按条件汇总.xls").Sheets(2).Range("A65536").End(3).Row + 1
修改红色部分代码试试。

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

[求助] 难题，帮忙修改一下，以A列为所列数据为基础，汇总余额表的H-K列数据相应数据

评分

评分

评分

[求助] 难题，帮忙修改一下， 以A列为所列数据为基础，汇总余额表的H-K列数据相应数据

评分

评分

评分

[求助] 难题，帮忙修改一下，以A列为所列数据为基础，汇总余额表的H-K列数据相应数据