这是一种可能是您需要的 90% 的方法(在vba中,因为它更容易测试!)
简而言之:
- 该代码用于
Dir
打开= "c:\temp\"下的每个xls * 文件strDir
- 在该工作簿的每个工作表中找到真正的最后一个单元格以设置工作范围
- 代码循环遍历该范围的每一行,并为“@”过滤该列的一维数组
- 然后将过滤后的字符串写入csv文件
等等
[更新:现在的代码]
- 循环通过行而不是列,这避免了大小问题,并且输出现在按行匹配输入文件
- 在电子邮件列表转储前加上工作簿和工作表名称
代码
Sub GetEm()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim strFile As String
Dim strEmail As String
Dim strDir As String
Dim strFiltered As String
Dim objFSO As Object
Dim objTF As Object
With Application
lngcalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set objFSO = CreateObject("scripting.filesystemobject")
strDir = "c:\tmp\"
strFile = Dir(strDir & "*.xls*")
Set objTF = objFSO.createtextfile(strDir & "output.csv", 2)
Do While Len(strFile) > 0
Set wb = Workbooks.Open(strDir & strFile, False)
For Each ws In wb.Sheets
Set rng1 = ws.Cells.Find("*", ws.[a1], xlFormulas, , xlByRows, xlPrevious)
'avoid blank sheets
If Not rng1 Is Nothing Then
Set rng2 = ws.Cells.Find("*", ws.[a1], xlFormulas, , xlByColumns, xlPrevious)
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, rng2.Column))
'avoid array errors on sheets with data only in A1
If rng2.Columns.Count = 1 Then Set rng2 = rng2.Resize(rng2.Rows.Count, 2)
For Each rng3 In rng2.Rows
strFiltered = Join(Filter(Application.Transpose(Application.Transpose(rng3)), "@"), ",")
If Len(strFiltered) > 0 Then
objTF.writeline (wb.Name & "," & ws.Name & ",") & strFiltered
End If
Next
End If
Next
wb.Close False
strFile = Dir
Loop
Set wb = Workbooks.Open(strDir & "output.csv", False)
wb.Sheets(1).Columns.AutoFit
With Application
.Calculation = lngcalc
.EnableEvents = True
.ScreenUpdating = True
End With
结束子