从电子表格中提取行并根据条件

Question

我正在寻找一个宏，它将遍历一个包含许多excel文件的文件夹，并为每个文件循环遍历每一行（从第4行开始），对于每一行，查看列“d”中的值是什么并将该行粘贴到名为“d”列中的值的特定excel文件中。如果文件不存在，则需要在粘贴行之前先创建它（在粘贴时从第4行开始）。新创建的文件的文件名将是“d”列中的任何值。如果文件已经创建，则正在复制的行将仅附加到相应的文件（给定行中的列d的值）。希望这是有道理的。

这是我到目前为止的一些代码。我的代码似乎不想遍历所有文件。我是Excel VBA的新手，所以非常感谢帮助！非常感谢你提前!!

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

OK, try this:

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