L oop через файлы в папке, размещать контент в пустые столбцы в мастере, для каждого исходного файла в новой строке мастер-файла

Question

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

У меня уже есть все, кроме правильной вставки:

Каждый термин, который он находит в исходном файле, должен быть отправлен в следующий пустой столбец в главном файле, и для каждого нового исходного файла, через который проходит l oop, он должен отправлять найденный материал в новую строку в главном файле.

Ниже то, что у меня уже есть.

Private Const sPath As String = "F:\ExamplePath"


Sub LoopThroughFiles()

Dim sFile As String 'File Name
Dim sExt As String 'File extension 
    
    sExt = "xlsx" 
    
    'loop through each file name and open it if the extension is correct
    sFile = Dir(sPath)
    Do Until sFile = ""
        If Right(sFile, 4) = sExt Then GetInfo sFile
        sFile = Dir
    Loop


End Sub

Private Sub GetInfo(sFile As String)

Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String

 On Error GoTo errHandle
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Set wbFrom = Workbooks.Open(sPath & sFile)
    
    
    
    'finds Search-Term
    With wbFrom.Sheets(1).Cells
    Set cl = .Find("necrosis_left", After:=.Range("C2"), LookIn:=xlValues)
        If Not cl Is Nothing Then
            strAddress = cl.Address
            cl.Select
            Selection.Copy
        iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
        Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
        End If
     End With
        
        
    'finds other Search-Term
    With wbFrom.Sheets(1).Cells
    Set cl = .Find("necrosis_right", After:=.Range("C2"), LookIn:=xlValues)
        If Not cl Is Nothing Then
            strAddress = cl.Address
            cl.Select
            Selection.Copy
        iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
        Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
        End If
     End With
       
   'many more search terms


    
       wbFrom.Close (False)
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set wbFrom = Nothing
    
Exit Sub
errHandle:
MsgBox Err.Description
    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
    
End Sub

Итак, я точно знаю, что моя проблема находится здесь:

iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells

Но я не могу понять, как он отправляется в пустой столбец вместо пустой строки, не говоря уже о том, как сделать его go вниз по строке в главном файле для каждого нового исходного файла.

Answer 1

Нашел ответ на свой вопрос!

Первым шагом было заменить строку вставки, приведенную выше, на следующее:

Me.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll

Это вставляет каждую скопированную ячейку в следующий пустой столбец в строке 1.

Чтобы начать новую строку для каждого исходного файла, через который проходит l oop, необходимо было объявить переменную publi c, которая подсчитывала каждую итерацию. Окончательный код выглядит следующим образом:

Private Const sPath As String = 'enter your path
Public Zeile As Integer 'public variable


Sub LoopThroughFiles()

Dim sFile As String 'File Name
Dim sExt As String 'File extension you wish to open
    
    
   Zeile = 1 'important for not start pasting in row 0 (which is impossible)
    sExt = "xlsx" 'Change this if extension is different
    
    'loop through each file name and open it if the extension is correct
    sFile = Dir(sPath)
    Do Until sFile = ""
        If Right(sFile, 4) = sExt Then GetInfo sFile
        sFile = Dir
        Zeile = Zeile + 1 'goes up each iteration
    Loop


End Sub

Private Sub GetInfo(sFile As String)

Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String

 On Error GoTo errHandle
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Set wbFrom = Workbooks.Open(sPath & sFile)
    
   
     'copy the following block for each term you want to search for
    With wbFrom.Sheets(1).Cells
    Set cl = .Find("searchterm", After:=.Range("C2"), LookIn:=xlValues)
        If Not cl Is Nothing Then
            strAddress = cl.Address
            cl.Select
            Selection.Copy
       Me.Cells(Zeile, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll 'the rows are controlled via the public variable 
        End If
     End With

      wbFrom.Close (False)
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set wbFrom = Nothing
    
Exit Sub
errHandle:
MsgBox Err.Description
    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
    
End Sub

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

Спасибо!