刪除「不」包含某些文字，或者僅複製做

Question

的情況細胞Excel列：

• 我有數以百計的Excel文件（.xls和.xlsx）;
• 這些文件中的每一個都包含多個工作表;
• 這些工作表中的每一個都有多列信息（在這種情況下是聯繫人詳細信息）。
• 但是，這些文件（甚至任何文件中的任何表單）都不是格式相同的（例如，有時電子郵件地址可能在J列中，有時在列A或D等中;有時它們會被標記爲「電子郵件」，有時會被標記爲「電子郵件地址」，有時根本沒有標籤）。

我需要將所有文件中所有工作表的電子郵件地址合併爲一個單一文本文件。

我打算在任

1. 刪除所有不包含電子郵件地址列（即不包含「@」的所有內容），然後每片轉換爲每個文件內一個csv/txt文件。
2. 或者從每個文件的每張表格複製包含「@」的每個單元格並將其粘貼到一個csv/txt文件中。

我該怎麼做呢？這兩種解決方案之一？任何人？

（注：所有的Excel文件都位於同一個文件夾）

非常感謝！

Answer 1

以下是一種方法，可能是您需要的90％（在vba中，因爲它更容易測試！）

簡而言之：

1. 該代碼使用Dir打開每XLS * strDir下文件= 「C：\ TEMP \」
2. 真正最後一個單元是在該每一片材中發現工作簿來設置工作範圍
3. 代碼循環遍歷該範圍的每一行，並過濾該列的一維數組以獲得「@」
4. 然後將已過濾的字符串寫入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 

末次