从电子表格中提取行并放入多个电子表格

Question

我想遍历一个包含 Excel 文件的文件夹，对于每个文件，遍历每一行（从第 4 行开始），对于每一行，查看“d”列中的值并将该行粘贴到特定的以“d”列中的值命名的 Excel 文件。

• 如果文件不存在，则需要在粘贴行之前创建它（粘贴时从第 4 行开始）。新创建文件的文件名将是“d”列中的任何值。

• 如果文件存在，将附加被复制的行（给定行中 d 列的值）。

我的代码不想遍历所有文件。

Sub CopyRowsIntoAppSpreadsheet()

Dim LastRow As Integer, i As Integer, erow As Integer
Dim AppFileName As String
Dim FilePath As String
Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook

On Error Resume Next

Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)

    .Title = "Please select a folder"
    .Show
    .AllowMultiSelect = False

    If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
        MsgBox "You did not select a folder"
        Exit Sub
    End If

    MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder

End With

MyFile = Dir(MyFolder) 'DIR gets the first file of the folder

'Loop through all files in a folder until DIR cannot find anymore

Do While MyFile <> “”

    'Opens the file and assigns to the wbk variable for future use
    Set wbk = Workbooks.Open(FileName:=MyFolder & MyFile)

    'Replace the line below with the statements you would want your macro to perform
    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    For i = 4 To LastRow

        Range("d" & i).Select
        AppFileName = Selection.Value
        Rows(i).Select
        Selection.Copy
        FilePath = "C:\Users\Gary\Desktop\Ex Folder\" & AppFileName & ".xlsx"

        If Not Dir(FilePath, vbDirectory) = vbNullString Then
            Workbooks.Open FileName:=FilePath
            Worksheets("Sheet1").Select
            erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            ActiveSheet.Cells(erow, 1).Select
            ActiveSheet.Paste
            Cells.Select
            Cells.EntireColumn.AutoFit
            ActiveWorkbook.Save
            ActiveWorkbook.Close
            Application.CutCopyMode = False

        Else
            Dim wkb As Workbook
            Set wkb = Workbooks.Add
            Rows(4).Select
            ActiveSheet.Paste
            wkb.SaveAs FileName:=FilePath
            Cells.Select
            Cells.EntireColumn.AutoFit
            ActiveWorkbook.Save
            ActiveWorkbook.Close
            Application.CutCopyMode = False

        End If

    Next i

    MyFile = Dir 'DIR gets the next file in the folder

Loop

Application.ScreenUpdating = True

MsgBox "Macro has completed! Woot! Woot!"

End Sub

Answer 1

好的，试试这个：

Option Explicit
Sub CopyRowsIntoAppSpreadsheet()
Dim LastRow As Integer, erow As Integer, Rowcounter As Long
Dim AppFileName As String
Dim FilePath As String
Dim MyFolder As String
Dim MyFile As String
Dim Source As Workbook, shSource As workseet, Dest As Workbook, shDest As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
    MsgBox "You did not select a folder"
    Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do Until MyFile = ""
    DoEvents
    Set Source = Workbooks.Open(Filename:=MyFolder & MyFile)
    Set shSource = Source.Sheets(1)
    LastRow = shSource.Range("A" & Rows.Count).End(xlUp).Row
    For Rowcounter = 4 To LastRow
        'get the name of the workbook to copy to
        AppFileName = Source.Cells(Rowcounter, 4)
        FilePath = "C:\Users\Gary\Desktop\Ex Folder\" & AppFileName & ".xlsx"
        'and open it
        If FileExists(FilePath) Then
            Set Dest = Workbooks.Open(Filename:=FilePath)
        Else
            Set Dest = Workbooks.Add
        End If
        Set shDest = Dest.Sheets(1)
        'get the bottom row of the destination sheet
        erow = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Row
        shSource.Cells(Rowcounter, 1).EntireRow.Copy Destination:=shDest.Cells(erow + 1, 1)
        Dest.SaveAs Filename:=FilePath
        Dest.Close
    'continue with next row
    Next Rowcounter
    Source.Close
    'repeat for next file
    MyFile = Dir()  'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
MsgBox "Macro has completed! Woot! Woot!"
End Sub
Function FileExists(FilePath As String) As Boolean
Dim FSO As Object
Dim sFile As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(FilePath) Then
    FileExists = False
Else
    FileExists = True
End If
End Function

Answer 2

我删除了误用的 On Error Resume Next 并替换了 ActiveWorkbook 和 ActiveSheet 引用。这在大多数情况下就足够了。

这里似乎 Dir 的第二次使用干扰了第一次，因此以不同的方式测试工作簿的存在。

Option Explicit

Sub CopyRowsIntoAppSpreadsheet()

Dim LastRow As Long
Dim i As Long
Dim erow As Long

Dim AppFileName As String
Dim FilePath As String
Dim MyFolder As String
Dim MyFile As String

Dim wbk As Workbook
Dim wbkTarget As Workbook

Dim sht As Worksheet

'On Error Resume Next   ' Misused here

'Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)

    .Title = "Please select a folder"
    .Show
    .AllowMultiSelect = False

    If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
        MsgBox "You did not select a folder"
        Exit Sub
    End If

    MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
    Debug.Print MyFolder

End With

MyFile = Dir(MyFolder) 'DIR gets the first file of the folder

'Loop through all files in a folder until DIR cannot find anymore
'Do While MyFile <> “”
Do While MyFile <> ""

    'Opens the file and assigns to the wbk variable for future use
    Set wbk = Workbooks.Open(FileName:=MyFolder & MyFile)

    LastRow = wbk.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

    For i = 4 To LastRow

        Range("d" & i).Select
        AppFileName = Selection.Value

        Rows(i).Select
        Selection.Copy

        FilePath = "C:\Users\Gary\Desktop\Ex Folder\" & AppFileName & ".xlsx"

        ' Reset wbkTarget or
        '  the tricky On Error Resume Next keeps the previous valid wbkTarget
        Set wbkTarget = Nothing
        On Error Resume Next
        Set wbkTarget = Workbooks.Open(FileName:=FilePath)
        ' turn off error bypass as soon as the purpose is served
        On Error GoTo 0

        If Not wbkTarget Is Nothing Then

            Set sht = wbkTarget.Worksheets("Sheet1")
            erow = sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

            With sht
                .Cells(erow, 1).Select
                .Paste
                .Cells.Select
                .Cells.EntireColumn.AutoFit
            End With

            wbkTarget.Close True

         Else ' Address the bypassed error

            Set wbkTarget = Workbooks.Add
            Set sht = wbkTarget.Worksheets("Sheet1")

            With sht
                .Rows(4).Select
                .Paste
                .Cells.Select
                .Cells.EntireColumn.AutoFit
            End With

            With wbkTarget
                .SaveAs FileName:=FilePath
                .Close
            End With

        End If

        Application.CutCopyMode = False

    Next i

    wbk.Close False

    MyFile = Dir 'DIR gets the next file in the folder
    Debug.Print MyFile

Loop

Application.ScreenUpdating = True

MsgBox "Macro has completed."

End Sub