【Excel】フォルダ内に無数のCSVファイルが入っています。ファイル名は不定で、文字コードはSHIFT JISです。

ひとつのファイルは500~600行程度ですが、行数はデータによって不定です。しかし、必ず3の倍数+1行となっています。
この全ファイルから特定の項目を抜き出し、統合した1ファイルにしたいのです。

*CSVファイルの内容
冒頭3行はヘッダなので無視。
以降は3行ごとの繰り返し。

3n+1行目(A列の[]に囲まれた文字列の抽出)
"[XXXXXX1] 日本語による説明",

3n+2行目(A列の文字列とE列の数値の抽出)
"YYYYYY1","日本語による説明",0,0,100,

3n+3行目は無視したい。
かつ、最終の1行はフッタなので無視。

そして、希望するフォーマットは(CSV的に記述すると)以下の通りとなります。
"XXXXX1","YYYYYY1",100
"XXXXX2","YYYYYY2",50
以下つづく…

これを適当な名前をつけてXLSファイルとして保存してください。
また、作業が終わった多数のCSVファイルは削除して構いません。
手っ取り早そうなのはExcelのマクロのように思うのですが、他の方法でも構いません。

よろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 登録:2007/04/02 19:37:12
  • 終了:2007/04/03 09:46:04

回答(4件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912007/04/02 21:49:08

ポイント30pt

VBA で処理をする例です(とりあえずファイルは消さないようにしました)。


A1セルに対象となるフォルダを入力し

(1) makeFileList を実行します。

  例 C:\CsvData


A2セルに出力ファイル名(フォルダはA1)を入力し、

(2) makeNewFile を実行します。

  例 AllData.csv


とした場合、C:\CsvData\AllData.csv に結果が出力されます。


'---------------------------------------------------------------------
' A1 フォルダ下にある CSV ファイルを B列にリストアップ
'---------------------------------------------------------------------
Sub makeFileList()
'-----------------------------------------------------------
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
'--- フォルダの有無のチェック
    If fso.FolderExists(Range("A1").Value) = False Then
        MsgBox "フォルダ[" & Range("A1").Value & "]がありません。"
        Exit Sub
    End If

'--- B列のクリア
    Columns("B").Clear

    Dim file As Object
    Dim lineNum As Long
    lineNum = 1
    For Each file In fso.getFolder(Range("A1").Value).Files
'--- CSVファイルの判定
        If InStr(UCase(file.Name), ".CSV") > 0 Then
            Cells(lineNum, "B").Value = file.Name
            lineNum = lineNum + 1
        End If
    Next
End Sub

'---------------------------------------------------------------------
' B列にあるファイルを規則にしたがって A2 ファイル(パスは A1)に出力
'---------------------------------------------------------------------
Sub makeNewFile()
'-----------------------------------------------------------
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim lastLine As Long
    lastLine = Range("B" & Rows.Count).End(xlUp).Row

'--- 出力ファイルをオープン
    Dim filePath As String
    filePath = Range("A1").Value & "\" & Range("A2").Value
    Dim dstFile As Object
    Set dstFile = fso.CreaTetextFile(filePath, True)
    
    Dim lines As Variant
    lines = Range("B" & Rows.Count).End(xlUp).Row
    Dim ll As Long
    Dim i As Long

    For i = 1 To lines
'--- 各CSVファイルを処理
        filePath = Range("A1").Value & "\" & Cells(i, "B").Value
        lines = Split(fso.OpenTextFile(filePath).ReadAll(), vbNewLine)
        For ll = 3 To UBound(lines) - 3 Step 3
'--- 各行を処理
            dstFile.WriteLine _
                """[" & lines(ll) & "]""," _
                & """" & lines(ll + 1) & """," _
                & lines(ll + 2)
        Next
    Next
    dstFile.Close
End Sub
id:raffine

申し訳ありません、質問の文字数制限で説明しきれませんでした。

元ファイルのうち必要な情報「だけ」を抜き出したいのです。

Mook様のマクロですと、ヘッダ・フッタのスキップはうまくいっていますがn+3行目のスキップがうまくいっていないようです。

あと、元ファイルにはすでに[ ]は記述されており、統合ファイル作成時には除去してしまいたいのです。

ただ、この結果をもとにすれば簡単な操作で目的は達せそうです。

ありがとうございました。

もう少し引き続き募集してみます。

2007/04/03 09:19:11
id:nandedarou No.2

nandedarou回答回数230ベストアンサー獲得回数342007/04/02 22:03:29

(1)csvファイルをダブルクリックして、エクセルで読み込む。

「新規テキスト文」というシートに読み込まれたものとして、以下、解説します。

(2)シートを追加する。

シート名のタブを右クリック→[挿入]をクリック→ワークシートが選択されているのを確認→[OK]をクリック

「Sheet1」というシートが追加されたものとして、以下、解説します。

(3)Sheet1のA1セルに、次の式を入力する。

=MID(OFFSET(新規テキスト文!$A$1,3*ROW(),0),2,FIND("]",新規テキスト文!$A$1)-2)

(4)Sheet1のB1セルに、次の式を入力する。

=OFFSET(新規テキスト文!$A$1,3*ROW()+1,0)

(5)Sheet1のC1セルに、次の式を入力する。

=OFFSET(新規テキスト文!$A$1,3*ROW()+1,4)

(6)範囲A1:C1を必要なだけ下にコピーして下さい。

※コピーのやり方

囲A1:C1をマウスで選択すると、太い線の四角で囲まれる。→その四角の右下の角を下にドラッグするとコピーされます。

(7)式を値に変換する。

データが表示された範囲を全て選択→右クリック→コピー→右クリック→形式を選択して貼り付け→[値]をチェック→[OK]

(8)「新規テキスト文」というシートを削除し、このブックを保存して完成。

以上です。

id:raffine

申し訳ありませんが、数千あるファイルをすべて「ダブルクリックで開く」というのは現実的ではありません。

2007/04/03 09:00:38
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912007/04/03 09:26:22

ポイント30pt

失礼しました。

仕様を読み間違えてましたね。


日本語の説明内に「, 」がないことが前提ですが、処理の部分を下記に置き換えてみてどうでしょうか。

    Dim words As Variant
    For i = 1 To lines
'--- 各CSVファイルを処理
        filePath = Range("A1").Value & "\" & Cells(i, "B").Value
        lines = Split(fso.OpenTextFile(filePath).ReadAll(), vbNewLine)
        For ll = 3 To UBound(lines) - 3 Step 3
'--- 各行を処理
            words = Split( lines(ll + 1), "," )
            dstFile.WriteLine _
                """[" & lines(ll) & "]""," _
                & """" & words(0) & """," _
                & words(4)
        Next
    Next

説明内に「,」がある場合は、別の方法が必要ですのでコメントください。

id:raffine

かなり近づいてきました。

元ファイルの1行目は、"[XXXXX1] 日本語"という状態ですが、このうちXXXXX1だけを抜き出したいのです。

つまり、角括弧の中身だけが必要で日本語部分も角括弧自体もばっさりカットしたいのですが…。

2007/04/03 09:41:24
id:Mook No.4

Mook回答回数1312ベストアンサー獲得回数3912007/04/03 09:41:37

ポイント30pt

たびたび失礼しました。

1行目の処理が、まだ仕様通りでは無いですね。


lastLine も正しく使われていなかったので、全体を修正して再掲しました。

こちらでどうでしょうか。

'---------------------------------------------------------------------
' A1 フォルダ下にある CSV ファイルを B列にリストアップ
'---------------------------------------------------------------------
Sub makeFileList()
'-----------------------------------------------------------
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
'--- フォルダの有無のチェック
    If fso.FolderExists(Range("A1").Value) = False Then
        MsgBox "フォルダ[" & Range("A1").Value & "]がありません。"
        Exit Sub
    End If

'--- B列のクリア
    Columns("B").Clear

    Dim file As Object
    Dim lineNum As Long
    lineNum = 1
    For Each file In fso.getFolder(Range("A1").Value).Files
'--- CSVファイルの判定
        If InStr(UCase(file.Name), ".CSV") > 0 Then
            Cells(lineNum, "B").Value = file.Name
            lineNum = lineNum + 1
        End If
    Next
End Sub

'---------------------------------------------------------------------
' B列にあるファイルを規則にしたがって A2 ファイル(パスは A1)に出力
'---------------------------------------------------------------------
Sub makeNewFile()
'-----------------------------------------------------------
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim lastLine As Long
    lastLine = Range("B" & Rows.Count).End(xlUp).Row

'--- 出力ファイルをオープン
    Dim filePath As String
    filePath = Range("A1").Value & "\" & Range("A2").Value
    Dim dstFile As Object
    Set dstFile = fso.CreaTetextFile(filePath, True)
    
    Dim ll As Long
    Dim i As Long

    Dim dataLines As Variant
    Dim data1 As String
    Dim words As Variant
    For i = 1 To lastLine
'--- 各CSVファイルを処理
        filePath = Range("A1").Value & "\" & Cells(i, "B").Value
        dataLines = Split(fso.OpenTextFile(filePath).ReadAll(), vbNewLine)
        For ll = 3 To UBound(dataLines) - 3 Step 3
'--- 各行を処理
            data1 = Replace(Left(dataLines(ll), InStr(dataLines(ll), "]") - 1), "[", "")
            words = Split(dataLines(ll + 1), ",")
            dstFile.WriteLine _
                """" & data1 & """," _
                & """" & words(0) & """," _
                & words(4)
        Next
    Next
    dstFile.Close
End Sub
id:raffine

ありがとうございます!これで仕様通りです!

終了させていただきます。

2007/04/03 09:44:48

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません