作者：iamlaosong
业务部门需要将各市公司收寄邮件按指定的条件筛选出来，然后合并到一张工作表中。源数据文件有16个，合并到一个工作表中，筛选条件可以自由设置。为此做了一个筛选合并工具。
1、指定一个文件名。如果这个文件存在，清空内容，如果不存在，创建一个。用这个文件来保存筛选合并后结果。
2、指定一个文件夹。如果这个文件夹存在，则处理这个文件夹下面的文件；如果不存在，这选择一个文件夹。
3、设置筛选条件。多个条件需要同时满足，某个条件可以设置多个值，内容如下图所示：
碰到的问题：
1、内存溢出。原本设想打开一个文件，将内容读到数组，然后进行筛选，将符合要求的记录复制到结果工作表中。但由于有些文件太大，有几十万条，读取的时候报内存溢出错误，现改为读取一行，筛选一行。
2、用数组读写Excel工作表内容的写法（maxrow和maxcol是最大行号和列号）：
读取整个工作表：
（1）mails = [A1].Resize(maxrow, maxcol).Value
（2）mails = Range(Cells(1, 1), Cells(maxrow, maxcol)).Value
读取row1行（读取1行）：
（1）mails = Range("A" & row1).Resize(1, maxcol).Value
（2）mails = Range(Cells(row1, 1), Cells(row1, maxcol)).Value
读取一个范围（假定读取m行n列）：
（1）mails = Range("B" & row1).Resize(m, n).Value
（2）mails = Range(Cells(row1, 2), Cells(row1+m-1, 2+n-1 )).Value
写工作表只要将上面语句倒过来，例如：
Range(Cells(mailno, 1), Cells(mailno, maxcol)).Value = mails
工具完整代码记录如下：
' 根据条件筛选出符合要求的邮件
Sub get_mail()
Dim objFDir As Object
Dim AddNowwb As Workbook
Dim mails(), record(), limit()
Dim myFile(200), sPath As String, sFile As String, SaveNew As String
thisfile = ThisWorkbook.Name '本文件的名字，这样赋值就可以随便改名了
Worksheets("系统参数").Select
If Cells(3, 2) = "Y" Or Cells(5, 2) = "y" Then '导出出库文件
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = False
End If
'读取筛选条件，非当前工作表要加上Value这个关键字
limitno = Range("F1").End(xlDown).Row
limit = Range("F1:H" & limitno).Value '读取目标列：F-H列
'打开或创建新文件
sDirect = Cells(5, 2) '数据源文件夹
FullName = ThisWorkbook.Path & "\" & sDirect
If Dir(FullName, vbDirectory) = vbNullString Then
'选择目录
Set objFDir = Application.FileDialog(msoFileDialogFolderPicker)
With objFDir
If .Show = -1 Then
' 如果单击了确定按钮(-1)，则将选取的路径保存在变量中。
sPath = .SelectedItems(1)
Else
Exit Sub '取消按钮（0）
End If
End With
Else
sPath = FullName
End If
'提取符合条件的文件
fileno = 0
sFile = Dir(sPath & "\*." & limit(3, 2))
Do While sFile <> ""
If InStr(sFile, limit(3, 3)) > 0 Then
fileno = fileno + 1
myFile(fileno) = sFile
sFile = Dir
Else
sFile = Dir
End If
Loop
'打开或新建结果保存文件
DatFile = Cells(6, 2) '新文件名称
FullName = ThisWorkbook.Path & "\" & DatFile
If Dir(FullName, vbNormal) <> vbNullString Then
Workbooks.Open Filename:=FullName
maxrow = ActiveSheet.UsedRange.Rows.Count
If maxrow > 1 Then
Range("A2:Z" & maxrow).ClearContents
End If
Else
'Application.SheetsInNewWorkbook = 3 '设置新工作簿中初始工作表数量
Set AddNowwb = Workbooks.Add '新建工作簿
AddNowwb.ActiveSheet.Name = "筛选结果"
AddNowwb.SaveAs Filename:=FullName
End If
'开始筛选合并源数据文件，由于文件较大，不适合读到数组处理（会产生内存溢出）
mailno = 1
For fnum = 1 To fileno
Application.StatusBar = "处理文件" & fnum & "：" & myFile(fnum)
DoEvents
Workbooks.Open Filename:=sPath & "\" & myFile(fnum)
maxrow = [A1].End(xlDown).Row
maxcol = [A1].End(xlToRight).Column
If maxrow = 0 Then
MsgBox myFile(fnum) & "文件为空！", vbOKOnly, "iamlaosong"
Exit For
End If
'mails = [A1].Resize(maxrow, maxcol).Value '读取1行：mails = Range("A" & row1).Resize(1, maxcol).Value
'ActiveWindow.Close
If mailno = 1 Then
'读取表头
mails = Range(Cells(1, 1), Cells(1, maxcol)).Value
Windows(DatFile).Activate
Range(Cells(1, 1), Cells(1, maxcol)).Value = mails
For k = 4 To limitno
limit(k, 2) = Asc(UCase(limit(k, 2))) - 64
Next k
mailno = 2
End If
Windows(myFile(fnum)).Activate
For row1 = 2 To maxrow
mails = Range(Cells(row1, 1), Cells(row1, maxcol)).Value
'对比内容筛选条件，条件从第4行开始
For k = 4 To limitno
tmp = limit(k, 3)
read = 0
If Len(tmp) > 0 Then
arrtmp = Split(tmp, " ")
'多值并列，满足一个即可
For kk = 0 To UBound(arrtmp)
If InStr(mails(1, limit(k, 2)), arrtmp(kk)) > 0 Then
read = 1
Exit For
End If
Next kk
Else
read = 1
End If
If read = 0 Then Exit For '任何一个条件不满足，即告结束
Next k
If read = 1 Then
'读取符合条件的数据
Windows(DatFile).Activate
Range(Cells(mailno, 1), Cells(mailno, maxcol)).Value = mails
Windows(myFile(fnum)).Activate
mailno = mailno + 1
End If
If row1 Mod 100 = 0 Then Application.StatusBar = "完成：" & Round(row1 * 100 / maxrow, 2) & "%"
DoEvents
Next row1
ActiveWindow.Close SaveChanges:=False
Next fnum
Windows(DatFile).Close SaveChanges:=True
Cells(6, 3) = "成功"
Application.StatusBar = "就绪"
Application.ScreenUpdating = True
MsgBox "邮件筛选合并完毕，共筛选出" & mailno - 2 & "件！", vbOKOnly, "iamlaosong"
End Sub
