多个工作簿合并

酒醒梦已残

我有很多个工作簿，里面就一张表，其中每个工作簿第1-2行是表头，内容一样的；第三行开始时内容不一样。求段代码，现在需要把这些工作簿合并成一个，不需要计算内容，只要把第三行开始的内容复制到一起就行。附件如下 多工作簿合并.rar (31.57 KB, 下载次数: 6)

2018-4-25 15:33 上传

点击文件名下载附件

stonelee2018

论坛上很多，自己找个去改

xzj820607

Sub 合并工作簿()
    Dim FilesToOpen
    Dim x As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets().Move After:=ThisWorkbook.Sheets _
          (ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub


Sub 合并工作表()
For Each st In Worksheets
If st.Name <> ActiveSheet.Name Then st.UsedRange.Offset(0, 0).Copy [a1048576].End(xlUp).Offset(1, 0)
Next
End Sub
Sub 删除其他工作表()
Dim arr()
Application.DisplayAlerts = False
A = ActiveWorkbook.ActiveSheet.Name
icount = Sheets.Count
For i = 1 To icount
  t = Sheets(i).Name
  Sheets(i).Visible = -1
  If t <> A Then
     r = r + 1
     ReDim Preserve arr(1 To r)
   arr(r) = t
  End If
Next
Sheets(arr).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

End Sub

Sub 清空本表()
    Cells.Select
    Selection.Clear
    Range("A1").Select
End Sub

Sub 导出()
    Application.ScreenUpdating = False
    Dim str As String
    Cells.Select
    str = Replace(ActiveWorkbook.Name, ".xlsm", "") & Format(Now, "yyyymmdd-hhmmss")
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ChDir "C:\桌面"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\桌面\" & str & ".xlsx"
        Range("A1").Select
ActiveWindow.Close
Application.ScreenUpdating = True

End Sub

xzj820607

这个表中的东西,部分需要你改.电脑中有需要有文件夹"C:\桌面"

LMY123

ADO合并同夹多薄首表，无字段名

lsc900707

Sub gj23w98()
    tms = Timer
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    Application.ScreenUpdating = False
    ReDim brr(1 To 3000, 1 To 22)
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            n = n + 1
            Set sh = GetObject(p & f).Sheets(1)
            Arr = sh.[a1].CurrentRegion
            Workbooks(f).Close False
            For i = 3 To UBound(Arr)
                m = m + 1
                For j = 1 To 22
                    brr(m, j) = Arr(i, j)
                Next
            Next
        End If
        f = Dir
    Loop
    Set sh = Nothing
    With Sheet1
        .Range("a3:v" & Rows.Count).ClearContents
        .[a3].Resize(m, 22) = brr
    End With
    Application.ScreenUpdating = True
    MsgBox "合并完成！" & "用时：" & Format(Timer - tms, "0.0000") & "秒"
End Sub

lsc900707

附件供测试：

酒醒梦已残

lsc900707 发表于 2018-4-25 19:03
附件供测试：

谢谢大神，搞定

lrh788

学习了！！！