將工作簿合併到一個主工作表中

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