删除“不”包含特定文本的Excel列，或仅复制所做的单元格

情况：

• 我有数百个excel文件（ .xls和.xlsx ）;
• 每个这些文件都包含多个表单;
• 每个表单都有多列信息（在这种情况下是联系方式）。
• 然而，这些文件（甚至任何文件中的任何一张）都不是格式相同的（例如，有时电子邮件地址可能在J列中，有时在列A或D等中;有时它们将被标记为“电子邮件“，有时会被标记为”电子邮件地址“，有时根本没有标签）。

我需要将所有文件中所有表单的电子邮件地址合并到一个文本文件中。

我正在计划

1. 删除所有不包含电子邮件地址的列（即不包含“@”的所有列），然后将每个文件中的每个表转换为csv / txt文件。
2. 或者从每个文件的每个工作表复制包含“@”的每个单元格，并将其粘贴到一个csv / txt文件中。

我到底要怎么做呢？ 这些解决scheme之一？ 任何人？

（注意：所有的excel文件都位于同一个文件夹中）

非常感谢！

Answer 1

这里有一个方法可能是你所需要的90％（在vba中，因为testing更容易！）

简而言之：

1. 代码使用Dir打开strDir =“c：\ temp \”下的每个xls *文件
2. 在该工作簿的每个工作表中find真正的最后一个单元格以设置工作范围
3. 代码遍历该范围的每一行，并过滤该列的一维数组“@”
4. 过滤后的string被写入一个csv文件

等等

[更新：现在的代码]

– 通过行循环而不是列避免了大小问题，输出现在匹配input文件的行
– 将电子邮件列表转储与工作簿和工作表名称相加

码

 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 

结束小组