[已解决]合并工作薄

songdg

在网上找了一段合并工作薄的代码，但不知道为什么前面多了一行空白。

Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
If Num = 1 Then
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
Else
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
End If
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"

最佳答案

月排行榜 / 总排行榜

zjdh

2016-8-6 13:37

你的宏修改很简单：
Sub TEST()
    Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long
    Dim Num As Long, sh As Boolean
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls")
    AWbName = ActiveWorkbook.Name
    Num = 0
    sh = True
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            Num = Num + 1
            With Workbooks(1).ActiveSheet
                For G = 1 To Sheets.Count
                    If sh Then
                        Wb.Sheets(G).UsedRange.Copy .Range("A65536").End(xlUp)(1)
                        sh = False
                    Else
                        Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Range("A65536").End(xlUp)(2)
                    End If
                Next
                WbN = WbN & Chr(13) & Wb.Name
                Wb.Close False
            End With
        End If
        MyName = Dir
    Loop
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

跳转到最佳答案楼层

zjdh

代码呢？

songdg

zjdh 发表于 2016-8-5 11:51
代码呢？

已经更新了帖子

泡泡sue

你是只想合并工作簿的内容么？这个我平时就在用来合并订单的
Sub Macro1()
    Dim MyPath$, MyName$, lc&, m&, sh As Worksheet
    Set sh = ActiveSheet
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    Application.ScreenUpdating = False
    sh.UsedRange.Clear
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            m = m + 1
            With GetObject(MyPath & MyName)
                With .Sheets(1)
                    If m = 1 Then
                        .UsedRange.Copy sh.Cells(1, 1)
                    Else
                        .UsedRange.Copy sh.Cells(65536, 1).End(xlUp).Offset(1)
'                        .UsedRange.Offset(4).Copy sh.Cells(65536, 1).End(xlUp).Offset(1)'如果后面的不要表头用这一句
                    End If
                End With
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

songdg

泡泡sue 发表于 2016-8-5 17:04
你是只想合并工作簿的内容么？这个我平时就在用来合并订单的
Sub Macro1()
    Dim MyPath$, MyName$, lc ...

谢谢，你的答案满足我的要求，但是我还是想知道如何改才能删除前面空白哪一行。

zjdh

你的宏修改很简单：
Sub TEST()
    Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long
    Dim Num As Long, sh As Boolean
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls")
    AWbName = ActiveWorkbook.Name
    Num = 0
    sh = True
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            Num = Num + 1
            With Workbooks(1).ActiveSheet
                For G = 1 To Sheets.Count
                    If sh Then
                        Wb.Sheets(G).UsedRange.Copy .Range("A65536").End(xlUp)(1)
                        sh = False
                    Else
                        Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Range("A65536").End(xlUp)(2)
                    End If
                Next
                WbN = WbN & Chr(13) & Wb.Name
                Wb.Close False
            End With
        End If
        MyName = Dir
    Loop
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

songdg

谢谢，能解析一下End(xlUp)(1)和End(xlUp)(2)，我百度也没能找到答案。

zjdh

End(xlUp)(1)=End(xlUp).Offset(1)
..............

zjdh

End(xlUp)(1)=End(xlUp).Offset(0) 因此可以简化为 End(xlUp)
End(xlUp)(2)=End(xlUp).Offset(1)

songdg

问题解决，谢谢兄弟的帮助。