Блог

Я хочу перебрать папку с файлами Excel и для каждого файла просмотреть каждую строку (начиная со строки 4) и для каждой строки посмотреть, какое значение находится в столбце «d», и вставить эту строку в конкретный файл Excel с именем, каким бы ни было значение в столбце «d».

• Если файл не существует, его необходимо будет создать перед вставкой строки (при вставке начинайте со строки 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) amp; "" '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 amp; MyFile)

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

    For i = 4 To LastRow

        Range("d" amp; i).Select
        AppFileName = Selection.Value
        Rows(i).Select
        Selection.Copy
        FilePath = "C:UsersGaryDesktopEx Folder" amp; AppFileName amp; ".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
  

Хорошо, попробуйте это:

 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) amp; "" '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 amp; MyFile)
    Set shSource = Source.Sheets(1)
    LastRow = shSource.Range("A" amp; 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:UsersGaryDesktopEx Folder" amp; AppFileName amp; ".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
  

Я удалил неправильно используемые 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) amp; "" '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 amp; MyFile)

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

    For i = 4 To LastRow

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

        Rows(i).Select
        Selection.Copy

        FilePath = "C:UsersGaryDesktopEx Folder" amp; AppFileName amp; ".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