将记录从文件夹中的多个工作簿复制到摘要工作簿

Question

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

Answer 1

这应该可以帮到你。您可能需要添加Scripting Runtime引用才能使用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