Попытка продолжить импорт списка, вместо этого он перезаписывает мой предыдущий импорт в VBA

Question

Я уже позаимствовал код из поста на этом сайте и сделал свой собственный. Однако я сталкиваюсь с проблемой, когда несколько файлов в пути к моей папке импортируют ПЕРЕД предыдущим импортом, а не ниже созданного списка.

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

Есть какие-либо идеи о том, как исправить?

Большое спасибо!

cwegz

Option Explicit

Const FOLDER_PATH = "Test Folder Path/"  'REMEMBER END BACKSLASH


Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row

   rowTarget = 2

   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If

   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False

   'set up the target worksheet
   Set wsTarget = Sheet1

   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""

      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY

      'import the data
      With wsTarget
         .Columns("A").Value = wsSource.Columns("A").Value 'this one works
         .Columns("B").Value = wsSource.Columns("C").Value 'this one works


         '.Range("A1" & rowTarget).Value = wsSource.Columns("A").Value
         '.Range("B1" & rowTarget).Value = wsSource.Columns("C").Value


         'optional source filename in the last column
         .Range("N" & rowTarget).Value = sFile
      End With

      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop

errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True

   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
   Set Selection = Nothing

    Sheets("Pull").Select
    Columns("B:B").Select
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="@", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

        Set Selection = Nothing

    Sheets("Pull").Select
    Columns("D:D").Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=";", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

        Set Selection = Nothing

    Sheets("WhiteList").Select
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="@", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

        Set Selection = Nothing



    Sheets("Summary").Select


End Sub

Answer 1

Вот один подход, который должен работать, если ваши таблицы данных непротиворечивы и не содержат пустых строк / столбцов.

Option Explicit

Const FOLDER_PATH = "Test Folder Path\"  'REMEMBER END BACKSLASH

Sub ImportWorksheets()

   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet, rngData As Range, numRows As Long
   Dim rowTarget As Long         'output row

   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If

   On Error GoTo errHandler
   Application.ScreenUpdating = False

   Set wsTarget = Sheet1

   'get first empty row, assuming colA always has values
   rowTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1

   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""

      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1)

      Set rngData = wsSource.Range("A1").CurrentRegion '<< assumes no empty rows/columns in your data table
      numRows = rngData.Rows.Count                     '<<

      With wsTarget
         .Cells(rowTarget, "A").Resize(numRows, 1).Value = rngData.Columns(1).Value
         .Cells(rowTarget, "B").Resize(numRows, 1).Value = rngData.Columns(3).Value
         'etc etc
         .Cells(rowTarget, "N").Value = sFile 'optional source filename in the last column
      End With

      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + numRows   '<<
      sFile = Dir()
   Loop

    'snipped....

End Sub