将工作簿合并到一个主工作表中

Question

我目前运行2个宏。

1）将我的文件夹中的所有csv全部打开并在一个工作簿中打开 - 这很好。

2）将它们全部组合到主工作表中。

我的问题是2.它跳过一些文件。这是大约250 csv文件，我试图把它放到一个。一些工作簿将是空白的，但仍会有标题。标题都是一样的。

这里是代码：

Sub Merge2MultiSheets() 
    Dim wbDst As Workbook 
    Dim wbSrc As Workbook 
    Dim wsSrc As Worksheet 
    Dim MyPath As String 
    Dim strFilename As String 

    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 
    MyPath = "PATH" ' change to suit 
    Set wbDst = Workbooks.Add(xlWBATWorksheet) 
    strFilename = Dir(MyPath & "\*.csv", vbNormal) 

    If Len(strFilename) = 0 Then Exit Sub 

    Do Until strFilename = "" 

     Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename) 

     Set wsSrc = wbSrc.Worksheets(1) 

     wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count) 

     wbSrc.Close False 

     strFilename = Dir() 

    Loop 
    wbDst.Worksheets(1).Delete 

    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 

End Sub 

和

Sub CopyFromWorksheets() 
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables 
    Dim sht As Worksheet 'Object for handling worksheets in loop 
    Dim trg As Worksheet 'Master Worksheet 
    Dim rng As Range 'Range object 
    Dim colCount As Integer 'Column count in tables in the worksheets 

    Set wrk = ActiveWorkbook 'Working in active workbook 

    For Each sht In wrk.Worksheets 
     If sht.Name = "Master" Then 
      MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _ 
      "Please remove or rename this worksheet since 'Master' would be" & _ 
      "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error" 
      Exit Sub 
     End If 
    Next sht 

    'We don't want screen updating 
    Application.ScreenUpdating = False 

    'Add new worksheet as the last worksheet 
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)) 
    'Rename the new worksheet 
    trg.Name = "Master" 
    'Get column headers from the first worksheet 
    'Column count first 
    Set sht = wrk.Worksheets(1) 
    colCount = sht.Cells(1, 255).End(xlToLeft).Column 
    'Now retrieve headers, no copy&paste needed 
    With trg.Cells(1, 1).Resize(1, colCount) 
     .Value = sht.Cells(1, 1).Resize(1, colCount).Value 
     'Set font as bold 
     .Font.Bold = True 
    End With 

    'We can start loop 
    For Each sht In wrk.Worksheets 
     'If worksheet in loop is the last one, stop execution (it is Master worksheet) 
     If sht.Index = wrk.Worksheets.Count Then 
      Exit For 
     End If 
     'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets 
     Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 
     'Put data into the Master worksheet 
     trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
    Next sht 
    'Fit the columns in Master worksheet 
    trg.Columns.AutoFit 

    'Screen updating should be activated 
    Application.ScreenUpdating = True 
End Sub 

我的头从A3走：C3，上面是不需要的数据。

Answer 1

通过将CSV工作表复制到工作簿中，然后将数据复制到主选项卡，您正在做不必要的工作。只需将CSV中的数据直接带入预先加载的主选项卡（模板）即可。

此代码假定工作簿中有1个工作表，该工作表将运行已经定义了标题的代码。请参阅有关将10调整为实际拥有的列标题数的说明。

Option Explicit 

Sub LoadCSVs() 

Dim wsDest As Worksheet 
Set wsDest = ThisWorkbook.Worksheets("Master") 

With wsDest 

    'clear old data if needed 
    If Len(.Range("B2")) Then 
     Intersect(.UsedRange, .UsedRange.Offset(1)).Clear 'removes old data 
    End If 

End With 

Application.ScreenUpdating = False 

Dim MyPath As String 
MyPath = "PATH" ' change to suit 

Dim strFilename As String 
strFilename = Dir(MyPath & "\*.csv", vbNormal) 

If Len(strFilename) = 0 Then Exit Sub 

Do Until strFilename = "" 

    Dim wbSrc As Workbook 
    Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename) 

    Dim wsSrc As Worksheet 
    Set wsSrc = wbSrc.Worksheets(1) 

    With wsSrc 

     If Len(.Range("B2")) Then 

      Dim vData As Variant 'load data to variant 
      vData = Intersect(.UsedRange, .UsedRange.Offset(1)) 

      'place on master tab               'adjust to column header length 
      wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Offset(1).Resize(UBound(vData), 10).Value = vData 

     End If 

    End With 

    wbSrc.Close False 

    strFilename = Dir() 

Loop 

End Sub 

Answer 2

该索引可能不可靠，您可能会过早退出循环。

For Each sht In wrk.Worksheets 

    If sht.Name <> "Master"    
     'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets 
     Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 
     'Put data into the Master worksheet 
     trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
    End If 

Next sht 

Answer 3

试试这个AddIn。它会做你想做的。

https://www.rondebruin.nl/win/addins/rdbmerge.htm