複数のエクセルの特定の列からデータを抽出

質問

特定のフォルダに格納されているエクセルファイル(500ぐらい)のC列に記載されている文字列を抜き出し、別のファイルに一覧化したいです。

要望として、
対象ファイルのC1は項目名が入っているので、C2から記載ある行まで抜き出してほしい。(C3で終わる場合とC5で終わる場合、そもそも記載ない場合もあり)
抜き出したものは、別シートにA列にファイル名、B列にその抜き出した項目を記載。

宜しくお願い致します。

回答No.5

Prome_Lin

追伸。

「シート名」には「【】」が前後に付いているものとして処理しています。

すなわち、２文字目から９文字を抜き出しています。

補足

その認識であっております!説明がいたらないところ、多数あったかと思いますが、何度もご対応頂き有難う御座いました。非常に、助かりました。

回答No.4

Prome_Lin

No.1の「Prome_Lin」です。

「C3」から読み込みを開始し、「エラーで止まらない」ようにし、なおかつ、シート名を指定して読み込むようにプログラムを変えました。

注意事項は、最初と同じです。

Option Explicit
On Error Resume Next
Dim a, b, c, d, i, r, s, t, u, v, w, x, y, z
Set t = CreateObject("Scripting.FileSystemObject")
Set u = t.GetFolder(".")
Set v = CreateObject("Excel.Application")
v.Application.DisplayAlerts = False
v.Visible = False
Set w = v.Workbooks.Add()
Set x = w.Worksheets(1)
a = 0
For Each b In u.Files
c = LCase(t.GetExtensionName(b.Name))
If c = "xls" or c = "xlsx" Then
s = Mid(b.Name, 2, 9)
Set y = v.Workbooks.Open(u & "\" & b.Name)
Set z = y.Worksheets(s)
r = z.Range("C1").End(-4121).Row
For i = 3 to r
a = a + 1
x.Cells(a, 1).Value = b.Name
x.Cells(a, 2).Value = z.Cells(i, 3).Value
Next
y.Close
Set z = Nothing
Set y = Nothing
End If
Next
w.SaveAs(u & "\Result.xlsx")
w.Close
v.Quit
Set z = Nothing
Set y = Nothing
Set x = Nothing
Set w = Nothing
Set v = Nothing
Set u = Nothing
Set t = Nothing
On Error GoTo 0
MsgBox("Finished!")

補足

完璧です!!!ほんとに、感謝です。有難う御座います!

回答No.3

Prome_Lin

No.1の「Prome_Lin」です。

３番目からなら、「For i = 2 to r」の「２」を「３」にするだけです。

次に、「エラーが出てもそのファイルは無視して」ということですが、「VBScript」では、エラー処理が貧弱なので、１行目の「Option Explicit」の下に「On Error Resume Next」と入れてください。何かエラーが出ても、エラーを出力せず、次にいきますが、「次に」というのは、ファイルを飛ばす、ということではなく、単にエラーの出た行の次の行を実行する、というだけですが、これで、エラーは出ません。また、気になるようでしたら、一番下の「MsgBox("Finished!")」の前に「On Error GoTo 0」を置けば、「On Error Resume Next」から復帰しますが、すでにプログラムが終わっているので、意味はありません。

最後に、「【Sheet名】XXXXXXX.xls もしくは、【Sheet名】XXXXXXX.xlsx」についてですが、具体的に書いて頂けませんか、「Sheet名」と「XXXXXXX.xls」の間の区切りが、何か明確なものがないと、プログラムで判断できません。それとも必ず「【】」が付いている？とか。

とにかく、「XXXXXXX」は必ず７文字です、とか、「Sheet名」は必ず５文字です、とか、「Sheet名」と「XXXXXXX」の間には、必ず、「_」が存在し、「_」は他には存在しませんとか、何かルールが分からないと、どこまでが「Sheet名」か判断が出来ません。

補足

ファイル名として、【数字3ケタとアルファベット1文字-数字4ケタ】文字(文字数バラバラ).xls or .xlsx

■例1)
ファイル名:【123K-5678】問題分析.xls
Sheet名:123K-5678

■例2)
ファイル名:【567A-1234】（未定）今後の予定.xlsx
Sheet名:567A-1234

ご回答になっていますでしょうか？
宜しくお願い致します。

回答No.2

imogasi

ファイルが５００もあれば、手作業でやるのは、無理でしょう。
だからVBAでやることになろう。
質問者が、ＶＢＡ・ＶＢＳｃｒｉｐｔの経験があるのかないのか、明記すべきだ。
回答をコピーして、貼り付けしたいのかもしれないが、
（経験が無ければ、回答を自分の場合（ケース）に合わせて、修正もできないだろうから、質問して回答をもらっても無駄。本件は回答をコピーして、貼り付けしても、うまく行きそうなタイプだが）
エクセルバージョンは２００７以後のものか、以前のものか、書くべきだ。
各ブックでシートは１つとしてよいのか、それで少し説明が変わる。
「特定のフォルダ」には対象外のファイル（エクセルファイル、その他）が含まれていないのだろうね。これを必ず書くこと。
（１）目的のフォルダをＦｏｒ　ＥａｃｈかＤｉｒ関数で１つづつ開き、（必要なら）エクセル・ファイルかどうか判別し、でなければ何もしないで、次の繰り返しに進む。
（２）エクセルファイル（ｘ）なら、ブックを開き、Ｓｈｅｅｔ１に当たるシートを開き、
Ｃ列の最下行からEnd(xlUp).Rowで、その列のデータ最終行（番号）を知る。
Ｃ２（最初だけはC1から？またはC2からにして（Y）のC1の項目名は別にセットするのも統一的で良いかも）から、データ最終行までを、集約ファイル（Y)のＢ列にコピーする。
その時、集約ファイル（Y)の（処理中の現在の）最終行はEnd(xlUp).Rowで知り、その次行以下に集約されるファイル（X)の目的のデータを(Yに)貼りつける。
集約ファイル（Y)のA列（最終行の次行）にはファイル名を代入する。
これを（X)の最終のファイルまで繰り返す。
終わればXとYのファイルをCloseする。
ーー
このタイプの質問は、たびたびあり、市販の解説書にもほぼ載っているし、WEBにも記事が多数あるのに、質問者は自分で探そうとしたのか。
Googleで「（エクセル）VBA フォルダ名 取得」や「エクセルVBA フォルダ　集約 」で検索してみたら、近いものが多数出る。
必要な要素技術は
（１）VBのDir関数か、VBScriptのForEach
（２）あるシートの１つの列の入力データ最終行（番号）を知るコード
の２つしかない問題だろう。あとはVBAの初歩的なコード。

回答No.1

Prome_Lin

以下のプログラムは、「VBScript（Microsoft Visual Basic Scripting Edition）」によって組んでいますので、「Windows」限定です。
「Windows」で、なおかつ「Excel」が入っているパソコンなら動くはずです。
一応、３個ほどファイルを適当に作って、間違いなく動くことを確認しています。

エクセルのファイルが500個ほどある フォルダ（関係ないエクセルファイルはその中には存在してはいけません）に、このプログラムを放り込んで、ダブルクリック（または、より確実に、シングルクリックして「Enter」）すると、処理を開始し、最後に「Finished!」と表示されます。
「Finished!」が表示されると、「Result.xlsx」というファイルが出来ているハズですので、そのファイルを開いてみてください。

なお、このプログラムをメモ帳やテキストエディタに貼り付け、適当な名前を付けるのですが、その際、拡張子を「.vbs」としてください。これは必ず「.vbs」でなければなりません。

あと、試していませんが、もしかしたら、フォルダ名にスペースがあると動かないかも知れません。出来れば、そのファイルの入っている直接のフォルダだけでなく、その上のすべての関係するフォルダ名のスペースを削除しておいてください。

Option Explicit
Dim a, b, c, i, r, t, u, v, w, x, y, z
Set t = CreateObject("Scripting.FileSystemObject")
Set u = t.GetFolder(".")
Set v = CreateObject("Excel.Application")
v.Application.DisplayAlerts = False
v.Visible = False
Set w = v.Workbooks.Add()
Set x = w.Worksheets(1)
a = 0
For Each b In u.Files
c = LCase(t.GetExtensionName(b.Name))
If c = "xls" or c = "xlsx" Then
Set y = v.Workbooks.Open(u & "\" & b.Name)
Set z = y.Worksheets(1)
r = z.Range("C1").End(-4121).Row
For i = 2 to r
a = a + 1
x.Cells(a, 1).Value = b.Name
x.Cells(a, 2).Value = z.Cells(i, 3).Value
Next
y.Close
Set z = Nothing
Set y = Nothing
End If
Next
w.SaveAs(u & "\Result.xlsx")
w.Close
v.Quit
Set z = Nothing
Set y = Nothing
Set x = Nothing
Set w = Nothing
Set v = Nothing
Set u = Nothing
Set t = Nothing
MsgBox("Finished!")

補足

早速有難う御座います!!素晴らしすぎて、涙が出そうです。
ちょっと補足として、2点お願いさせて下さい。
1.開始セルですが、C2ではなく、C3でした。申し訳ございません。
2.何等かのエラーが起きた場合でも、そのファイルは無視して、最後まで全ファイルを確認する。

あと、補足として、ファイル名とSheet名の関係性は下記のようになっています。
ファイル名：【Sheet名】XXXXXXX.xls もしくは、【Sheet名】XXXXXXX.xlsx

役立つ情報か不明ですが、共有させていただきます。

宜しくお願い致します。