从文件夹中的多个工作簿复制记录的汇总工作簿

Question

有多个工作簿就像这个格式的文件夹中。我需要摘要工作簿中除'@gmail.com'以外的记录。

Answer 1

这应该对你有用。您可能需要添加脚本运行时引用才能使用FileSystemObject。

Sub GetMail() 

Dim MySht As Worksheet 
Dim SrcWbk As Workbook 
Dim SrcSht As Worksheet 
Dim FSO As New FileSystemObject 
Dim Fl As File 

Set MySht = ThisWorkbook.Sheets(1) 
MySht.Range("A1").Value = "Procedure" 
MySht.Range("B1").Value = "Email" 

'Loop through all of the files in the folder 
For Each Fl In FSO.GetFolder("").Files 
    'Open the file 
    Set SrcWbk = Workbooks.Open(Fl.Path) 
    Set SrcSht = SrcWbk.Sheets(1) 
    'Loop down all of the rows 
    For x = 2 To SrcSht.Range("A2").End(xlDown).Row 
     'Check if it's a @Gmail.com address 
     If InStr(1, UCase(SrcSht.Cells(x, 2).Value), "@GMAIL.COM") = 0 Then 
      If MySht.Range("A2").Value = "" Then 
       MySht.Range("A2").Value = SrcSht.Cells(x, 1).Value 
       MySht.Range("A2").Offset(0, 1).Value = SrcSht.Cells(x, 2).Value 
      Else 
       MySht.Range("A1").End(xlDown).Offset(1, 0).Value = SrcSht.Cells(x, 1).Value 
       MySht.Range("A1").End(xlDown).Offset(1, 1).Value = SrcSht.Cells(x, 2).Value 
      End If 
     End If 
    Next 
    Set SrcSht = Nothing 
    SrcWbk.Close False 
    Set SrcWbk = Nothing 
Next 

End Sub