1

状況：

  • 私は何百ものExcelファイル（.xlsと.xlsx）を持っています。
  • これらの各ファイルには複数のシートが含まれています。
  • これらの各シートには、複数の情報列（この場合は連絡先の詳細）があります。
  • ただし、どのファイル（またはいずれかのファイル内のシート）も同じ形式ではありません（たとえば、電子メールアドレスがJ列、A列、D列などにある場合があります。「」というラベルが付いている場合もあります。 「email」、「Email Address」というラベルが付いている場合もあれば、まったくラベルが付いていない場合もあります）。

すべてのファイルのすべてのシートから1つのテキストファイルに電子メールアドレスを取得する必要があります。

私はどちらかを計画しています

  1. 電子メールアドレスを含まないすべての列（つまり、「@」を含まないすべての列）を削除してから、各ファイル内の各シートをcsv/txtファイルに変換します。
  2. または、各ファイルの各シートから「@」を含む各セルをコピーして、1つのcsv/txtファイルに貼り付けます。

いったいどうやってこれをやろうか？これらの解決策のどちらか？誰？

（注：すべてのExcelファイルは同じフォルダーにあります）

どうもありがとう！

4

1 に答える 1

2

これは、おそらく必要なものの90％である1つのアプローチです（テストが簡単だったので

要するに：

  1. このコードは、 = "c：\temp\"の下にあるDirすべてのxls *ファイルを開くために使用しますstrDir
  2. 作業範囲を設定するために、そのワークブックの各シートに真の最後のセルがあります
  3. コードはその範囲の各行をループし、その列の1D配列を「@」でフィルタリングします
  4. フィルタリングされた文字列は、ファイルに書き込まれます

等々

[更新：今すぐコード]

-サイズの問題を回避するために列ではなく行をループし、出力は行ごとに入力ファイルと一致するようになりました
-メーリングリストダンプの前にワークブックとワークシート名を付けます

コード

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

サブ終了

于 2012-11-14T12:03:33.507 に答える