VBA Циклически просматривайте книги Excel в папке и копируйте данные - Не просматривая все файлы - PullRequest
0 голосов
/ 11 декабря 2018

Я пытаюсь заставить макрос VBA перебирать все файлы xls в определенной папке.Приведенный ниже код работает по большей части.Тем не менее, у меня есть 42 файла в этой папке, и код перебирает только около 26 из них.Все они имеют одинаковое расширение файла.

Я думаю, что либо он не просматривает все файлы.Или он просматривает все файлы, однако существует проблема с последней переменной строки, и данные вставляются поверх.

Sub CopyDataBetweenWorkbooks()

    Dim wbSource As Workbook
    Dim shTarget As Worksheet
    Dim shSource As Worksheet
    Dim strFilePath As String
    Dim strPath As String

Application.ScreenUpdating = False

    ' Initialize some variables and
    ' get the folder path that has the files
    Set shTarget = ThisWorkbook.Sheets(1)
    strPath = GetPath

    ' Make sure a folder was picked.
    If Not strPath = vbNullString Then

        ' Get all the files from the folder
        strfile = Dir$(strPath & "*.xls", vbNormal)

        Do While Not strfile = vbNullString

            ' Open the file and get the source sheet
            Set wbSource = Workbooks.Open(strPath & strfile)
            Set shSource = wbSource.Sheets("Trend Report")


            'Copy the data
            Call CopyData(shSource, shTarget)

            'Close the workbook and move to the next file.
            wbSource.Close False
            strfile = Dir$()
        Loop
    End If

End Sub

' Procedure to copy the data.
Sub CopyData(ByRef shSource As Worksheet, shTarget As Worksheet)

    LastRowSource = shSource.Cells(Rows.Count, "B").End(xlUp).Row
    Dim strRANGE_ADDRESS As String
    Dim lastrow As String
    strRANGE_ADDRESS = "B15:H" & LastRowSource - 1

    'insert file name
    StrFileFullname = ActiveWorkbook.FullName
    shSource.Range("H15:H" & LastRowSource).Value = StrFileFullname

    'Copy the data.
    shSource.Range(strRANGE_ADDRESS).Copy

    'Set last row and paste
    lastrow = shTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1

    shTarget.Range("B" & lastrow).PasteSpecial xlPasteValuesAndNumberFormats

    ' Reset the clipboard.
    Application.CutCopyMode = xlCopy

End Sub


' Function to get the folder path
Function GetPath() As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Select a folder"
        .Title = "Folder Picker"
        .AllowMultiSelect = False

        'Get the folder if the user does not hot cancel
        If .Show Then GetPath = .SelectedItems(1) & "\"

    End With

End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...