[已解决]表册汇总

gaogege852 · 发表于 2013-3-20 20:40

请教如何将多个表内容汇总到一个表中，具体要求在附件中的汇总表中。

最佳答案

hwc2ycy

2013-3-20 21:17

本帖最后由 hwc2ycy 于 2013-3-20 21:19 编辑

放到要汇总的工作簿同一目录下。

hwc2ycy · 发表于 2013-3-20 21:11

Sub 汇总()
Dim file$, path$
Dim wb As Workbook
Dim arr(), lCount&
Dim arrPos, j As Byte
Application.ScreenUpdating = False
arrPos = Array("a3", "b3", "b4", "b5", "b6", "b7")
path = ThisWorkbook.path & Application.PathSeparator
file = Dir(path & "*.xls", vbNormal + vbDirectory)
Do While Len(file) > 0
If file <> ThisWorkbook.Name Then
lCount = lCount + 1
ReDim Preserve arr(1 To 6, 1 To lCount)
Set wb = GetObject(path & file)
With wb.Worksheets("sheet1")
For j = 1 To UBound(arr)
arr(j, lCount) = "'" & .Range(arrPos(j - 1))
Next
End With
wb.Close False
End If
file = Dir
Loop
Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lCount, 6) = WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
MsgBox "汇总完成"
End Sub

复制代码

hwc2ycy · 发表于 2013-3-20 21:13

本帖最后由 hwc2ycy 于 2013-3-20 21:18 编辑

Sub 汇总()
Dim file$, path$
Dim wb As Workbook
Dim arr(), lCount&
Dim arrPos, j As Byte
Application.ScreenUpdating = False
arrPos = Array("a3", "b3", "b4", "b5", "b6", "b7")
path = ThisWorkbook.path & Application.PathSeparator
file = Dir(path & "*.xls", vbNormal + vbDirectory)
Do While Len(file) > 0
If file <> ThisWorkbook.Name Then
lCount = lCount + 1
ReDim Preserve arr(1 To 6, 1 To lCount)
Set wb = GetObject(path & file)
With wb.Worksheets("sheet1")
For j = 1 To UBound(arr)
arr(j, lCount) = "'" & .Range(arrPos(j - 1))
Next
End With
wb.Close False
End If
file = Dir
Loop
Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lCount, 6) = WorksheetFunction.Transpose(arr)
Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox "汇总完成"
End Sub

复制代码

hwc2ycy · 发表于 2013-3-20 21:17

本帖最后由 hwc2ycy 于 2013-3-20 21:19 编辑

放到要汇总的工作簿同一目录下。

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