цикл по папке и извлечение данных из файлов Excel на основной лист и сохранение копии после завершения каждого вывода

Question

Привет! Я написал код в VBA, чтобы открыть определенные листы, скопировать данные рабочего листа и вставить вывод в другой лист.

У меня есть два вопроса, в настоящее время я сделал это, написав Имена Excel в каждом бите кода, это было бы хорошо для нескольких книг, но в настоящее время их более 50, и код будет смехотворно длинным. Мне было интересно, есть ли способ go через папку, содержащую файлы Excel, и go через список до завершения.

Sub Openworkbook()

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

'first worksheet to copy and paste

Workbooks.Open "C:\"

Set wsCopy = Workbooks("Isabella.xlsx").Worksheets("Sheet2")
  Set wsDest = Workbooks("Testcode1.xlsx").Worksheets("Sheet1")
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
  wsCopy.Range("A1:E86" & lCopyLastRow).Copy _
    wsDest.Range("A" & lDestLastRow)

Workbooks("Isabella.xlsx").Close SaveChanges:=True

'Second worksheet to copy and paste

Workbooks.Open "C:\"

Set wsCopy = Workbooks("Jacob.xlsx").Worksheets("Sheet2")
Set wsDest = Workbooks("Testcode1.xlsx").Worksheets("Sheet1")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
  wsCopy.Range("A1:E86" & lCopyLastRow).Copy _
    wsDest.Range("A" & lDestLastRow)

Workbooks("Jacob.xlsx").Close SaveChanges:=True


End Sub

Большое спасибо за вашу помощь.

********************************* UPDATE ************** ****************************

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

Answer 1

вот вам помощь в том, что я даю код и псевдокод

код

Sub CopyAndPaste(fullPath As String, wsDest As Worksheet)
    With Workbooks.Open(fullPath)
        With .Worksheets("Sheet2")
            .Range("A1:E" & .Cells(.Rows.count, "A").End(xlUp).Row).Copy wsDest.Cells(wsDest.Rows.count, "B").End(xlUp).Offset(1)
        End With
        .Close SaveChanges:=True
    End With
End Sub

, который является подпрограммой, вызываемой на каждой итерации псевдокода

псевдокод

Sub Openworkbook()

    Dim wsDest As Worksheet
    Set wsDest = Workbooks("Testcode1.xlsx").Worksheets("Sheet1")

    Dim fullPath As String

    for each ... 'code to loop through a folder files
        fullPath = ' extract the full path of current file
        CopyAndPaste fullPath, wsDest
    Next
    '
End Sub

, поэтому вам нужно всего лишь записать «настоящий» код в l oop через файлы папок, которых вы можете найти в net (и в SO). в основном)

Answer 2

Я закончил тем, что вернулся, немного поспал и начал писать код с нуля, и ниже я придумал. Надеюсь, это поможет

Sub RunIt()
Dim InputBook As Workbook
Dim OutputBook As Workbook
Dim DirFolder As String
Dim DirSel As String
Dim DirFile As String
Dim FileString As String
Dim InputArray As Variant
Dim LastLine As Long
Dim OutputName As String

Set OutputBook = ThisWorkbook

Application.ScreenUpdating = False

' Choose folder and file type (*.* for all files, I have used csv).

DirFolder = "G:\"
DirSel = "*.csv*"
'File output destination
DirOut = "C:\"

' This loops through all the files in the folder above:

    DirFile = Dir(DirFolder & DirSel)
    Do While Len(DirFile) > 0
        FileString = DirFolder & DirFile

        ' I've put in a condition here to pick up only the correct file:
        If Left(DirFile, 5) = "02008" Then
            OutputName = Replace(DirFile, ".csv", "")

            ' Open the file
            Set InputBook = Workbooks.Open(FileString)
              ' Measure the number of rows:
            LastLine = WorksheetFunction.CountIf(InputBook.Sheets(1).Range("A:A"), ">""") + 1
                'Put the data into an array:
            InputArray = InputBook.Sheets(1).Range("A1:L" & LastLine)
               ' Clear out the Lookup tab
            OutputBook.Sheets("Lookup").Range("A1:L1000").ClearContents
               ' Put the array data in:
            OutputBook.Sheets("Lookup").Range("A1:L" & LastLine) = InputArray
               ' Save a copy of the IBS_v022 file
            OutputBook.SaveCopyAs DirOut & "IBS Output " & OutputName & ".xlsm"

            InputBook.Close

        End If


        DirFile = Dir
    Loop


Set InputBook = Nothing
Set OutputBook = Nothing

MsgBox ("Complete")

End Sub
    enter code here