如何将多个工作簿按设定格式合并到同一工作簿中

msw2395

如图表所示，将4个不同工作簿按指定格式汇总在1个工作簿中，请老师们帮忙解答，谢谢！！

3190496160

Sub 合并()
Application.ScreenUpdating = False
Set sht = ThisWorkbook.Worksheets("汇总")
sht.UsedRange = Empty
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
y = 1
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(lj & f, 0)
        ar = wb.Worksheets(1).[a1].CurrentRegion
        wb.Close False
        sht.Cells(1, y).Resize(UBound(ar), UBound(ar, 2)) = ar
        y = y + 7
    End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

工作簿汇总.rar (45.46 KB, 下载次数: 11)

2024-7-20 09:55 上传

点击文件名下载附件

lln0618

Sub 汇总()

Application.DisplayAlerts = False '取消弹出框
Dim myPath$, myFile$, AK As Workbook

myPath = Application.ActiveWorkbook.Path & "\"  '当前文件路径
myFile = Dir(myPath & "*.xls*") '依次寻找*.xls文件

Do While myFile <> "" '当指定路径中有文件时进行循环
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile) '打开符合要求的文件

'-------------自定义的程序---------------------------------

   Columns("A:F").Select
    Selection.Copy

    Windows("汇总.xlsm").Activate
    ls = Cells(1, Columns.Count).End(xlToLeft).Column '获取最后一列列号

    Columns(ls + 2).Select
    ActiveSheet.Paste

'----------------------------------------------------------

AK.Save '表格保存
AK.Close '表格关闭
End If
myFile = Dir '寻找下一个文件
Loop

Application.DisplayAlerts = True '取消弹出框

  Windows("汇总.xlsm").Activate
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft






End Sub 工作簿汇总1.zip (46.13 KB, 下载次数: 7)

2024-7-20 10:06 上传

点击文件名下载附件

msw2395

3190496160 发表于 2024-7-20 09:55

谢谢3190496160老师解答!!

Qs18

试一下............

Qs18

Public Sub qs() '2024/7/20多工作簿合并
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim wb As Workbook, xb As Workbook, pt As String, m, x
Set wb = ThisWorkbook
na = wb.Name
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
pt = ThisWorkbook.Path & "\"   '相对路径及文件夹名称
Set 文件夹 = FSO对象.GetFolder(pt)
For Each i In 文件夹.Files '循环文件下的每一个文件
    If VBA.InStr(i, na) < 1 Then
   
        文件名 = FSO对象.GetBaseName(i)
        Set xb = Workbooks.Open(i, 0)
        m = m + 1
        arr = xb.Sheets(1).Range("a1").CurrentRegion
        If m = 1 Then
            wb.Sheets("汇总").Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
           
        Else
            x = wb.Sheets("汇总").Cells(1, 1000).End(xlToLeft).Column + 2
            wb.Sheets("汇总").Cells(1, x).Resize(UBound(arr), UBound(arr, 2)) = arr
           
        End If
        xb.Close
    End If
Next
Set xb = Nothing
Set wb = Nothing
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox "完毕！"
End Sub

Qs18

试一下...........

lushang2018