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

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

3 个答案: