遍历文件夹中的文件，将内容发布到主文件中的空列，对于主文件的新行中的每个源文件

Question

我对 VBA 很陌生，我正在做一个项目，我在一个文件夹中有多个 Excel 文件，每个文件的结构都相同，我想遍历每个文件，搜索特定术语在每个单独的文件中，将其复制并以特定方式将其粘贴到主文件中。

除了以正确的方式粘贴之外，我已经得到了所有内容：

它在源文件中找到的每个术语都应该发布到主文件中的下一个空列，对于循环经过的每个新源文件，它应该将找到的内容发布到主文件中的新行文件。

下面是我已经得到的。

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

但我不太清楚它是如何发布到空列而不是空行的，更不用说如何让它在每个新源文件的主文件中下降一行。

Answer 1

找到我自己问题的答案！

第一步是将上面的“粘贴行”替换为以下内容：

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

这会将每个复制的单元格粘贴到第 1 行中的下一个空列。

要为循环所经过的每个源文件开始一个新行，必须声明一个公共变量，该变量对每次迭代进行计数。最终代码如下所示：

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

结果循环遍历文件夹的所有文件，搜索特定术语并将每个结果粘贴到主文件的下一个空列中，但为每个源文件开始一个新行。

谢谢！