[[20190315151752]] 『VBA CSVファイル統合(各ファイルの項目列が違う』(ひまわり) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBA CSVファイル統合(各ファイルの項目列が違う)』(ひまわり)

お忙しい中、大変恐れ入ります。
20以上あるCSVファイルを1つのファイルに統合したいです。

ただ統合するのは以下の通り、他の掲示板で確認して、出来ました。
条件として、各個別CSVファイルのファイル名を
取りまとめるファイルのA列に追加して表示しております。

出来ないのは、各CSVファイルの列が集計開始の年月なのですが、
ファイルによって集計開始月が違う為、
列が違うデータを、揃えて統合する事が出来ず、困っております。
こちらだけ現在のコードに追加する方法を教えていただくことは出来ますでしょうか。

<元ファイル>
■ファイル1(CSV)
    2018年2月 2018年3月 2018年4月 2018年5月
項目1  数値    数値   数値    数値
項目2  数値    数値   数値    数値
項目3  数値    数値   数値    数値
項目4  数値    数値   数値    数値
項目5  数値    数値   数値    数値
項目6  数値    数値   数値    数値

■ファイル2(CSV)
    2017年12月 2018年1月 2018年2月 2018年3月 2018年4月 2018年5月  
項目1  数値    数値   数値    数値    数値   数値
項目2  数値    数値   数値    数値    数値   数値
項目3  数値    数値   数値    数値    数値   数値
項目4  数値    数値   数値    数値    数値   数値
項目5  数値    数値   数値    数値    数値   数値
項目6  数値    数値   数値    数値    数値   数値

同じフォルダ上に、他20ファイル(全てCSV)ほど、あります。

<理想の取りまとめファイル> 
            2017年12月 2018年1月 2018年2月 2018年3月 2018年4月 2018年5月  
■ファイル1  項目1               数値   数値    数値   数値
■ファイル1  項目2               数値   数値    数値   数値
■ファイル1  項目3               数値   数値    数値   数値
■ファイル1  項目4               数値   数値    数値   数値
■ファイル1  項目5               数値   数値    数値   数値
■ファイル1  項目6               数値   数値    数値   数値
■ファイル2  項目1   数値    数値    数値   数値    数値   数値
■ファイル2  項目2   数値    数値    数値   数値    数値   数値
■ファイル2  項目3   数値    数値    数値   数値    数値   数値
■ファイル2  項目4   数値    数値    数値   数値    数値   数値
■ファイル2  項目5   数値    数値    数値   数値    数値   数値
■ファイル2  項目6   数値    数値    数値   数値    数値   数値

******************************************

'---------------------------------------------------------------------
Private Sub try()

    Dim ws As Worksheet 
    Dim fd As String 
    Dim fn As String 
    Dim ret As String 
    Dim i As Long 
    Dim n As Long 
    Dim x As Long 
    Dim s As Long 

    fd = ThisWorkbook.Path & "\" 
    'fd = FDSELECT 'フォルダ選択の場合 

    If Len(fd) = 0& Then Exit Sub 
    Application.ScreenUpdating = False 
    'ActiveWorkbookにシートを追加して処理 
    Set ws = Sheets.Add 
    On Error GoTo errHndler 
    fn = Dir(fd & "*.csv") 

    x = 1 
    s = 1 
    Do Until Len(fn) = 0& 
        i = i + 1 
        'データCountにより次のセット先変更 
        n = n + x 
        '外部データ取り込み 
        x = CSVQRY(ws, fd & fn, ws.Cells(n, 2), s) 
        If x < 0 Then 
            Err.Raise Number:=1000, Description:="CSV読み込みに失敗" 
        ElseIf (n + x) >= Rows.Count Then 
            '行数overしてもエラーかからないため取り込み直し 
            ws.Rows(n).Resize(x).Delete 
            Set ws = Sheets.Add 
            n = 1 
            x = CSVQRY(ws, fd & fn, ws.Cells(n, 2), 1&) 
        End If 
        'ファイル名をA列にセット 
        ws.Cells(n, 1).Resize(x).Value = fn 
        s = 2 
        fn = Dir() 
    Loop 

    If i > 0 Then 
        ret = i & "files.done" 
    Else 
        ret = "no file" 
    End If 

errHndler:

    If Err.Number <> 0 Then 
        ret = Err.Number & vbTab & Err.Description 
        Debug.Print ret 
    End If 
    Application.ScreenUpdating = True 
    MsgBox ret 
    Set ws = Nothing 
End Sub 
'--------------------------------------------------------------------- 
Private Function CSVQRY(ByRef ws As Worksheet, _ 
                        ByRef fs As String, _ 
                        ByRef rs As Range, _ 
                        ByVal sr As Long) As Long 
    Dim cnt As Long 

    On Error GoTo errChk 
    With ws.QueryTables.Add(Connection:="TEXT;" & fs, _ 
                            Destination:=rs) 
        .AdjustColumnWidth = False 
        .TextFilePlatform = xlWindows 
        .TextFileStartRow = sr 
        .TextFileCommaDelimiter = True 
        .Refresh False 
        cnt = .ResultRange.Rows.Count 
        .Parent.Names(.Name).Delete 
        .Delete 
    End With 
    CSVQRY = cnt 
    Exit Function 
errChk: 
    CSVQRY = -1 
End Function 
'--------------------------------------------------------------------- 
Private Function FDSELECT() As String 'フォルダ選択Function 
    Dim obj As Object 
    Dim ret As String 

    Set obj = CreateObject("Shell.Application") _ 
              .BrowseForFolder(0, "SelectFolder", 0) 
    If obj Is Nothing Then Exit Function 
    On Error Resume Next 
    ret = obj.self.Path & "\" 
    If Err.Number <> 0 Then 
        ret = obj.Items.Item.Path & "\" 
        Err.Clear 
    End If 
    On Error GoTo 0 
    Set obj = Nothing 
    FDSELECT = ret 
End Function 

******************************************

< 使用 Excel:Excel2016、使用 OS:Windows7 >


 こちらが元ネタですか?

 https://blog.goo.ne.jp/end-u/e/94f4011afb22183757fc904804fa36e3

 回答でなくて失礼しました。
(でれすけ) 2019/03/15(金) 17:16

やりたいことはなんとなくわかりましたが、2点確認。

1.取りまとめファイルの項目行は、あらかじめ入力しておくのでしょうか?
2.csvファイルをそのままエクセルで(ブックとして)開くと問題が生じますか?

※場合によっては、私の手には負えないかもしれないです。

(もこな2) 2019/03/15(金) 19:39


最初は、別々のシートに取り込んで
最後に、「データ」タブにある統合機能を使います。

>現在のコードに追加する方法を

かなり削ったので、現在のコードで必要な部分は追加してください。

 Option Explicit

 Sub test()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim fd As String
    Dim fn As String
    Dim x As Long
    Dim adr As String

    Set wb = Workbooks.Add(xlWBATWorksheet)

    fd = ThisWorkbook.Path & "\"
    fn = Dir(fd & "*.csv")

    Do While fn <> ""
        Set ws = Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        With ws.QueryTables.Add(Connection:="TEXT;" & fd & fn, Destination:=ws.Cells(2))
            .TextFilePlatform = xlWindows
            .TextFileCommaDelimiter = True
            .Refresh False
            x = .ResultRange.Rows.Count
            .Parent.Names(.Name).Delete
            .Delete
        End With

        ws.Cells(2, 1).Resize(x - 1).FormulaR1C1 = "=""" & fn & """&CHAR(9)&rc[1]"
        adr = adr & " " & ws.Cells(1).CurrentRegion.Address(, , xlR1C1, True)

        fn = Dir()
    Loop

    With wb.Sheets(1)
        .Cells(1).Consolidate Sources:=Split(Trim(adr)), _
                Function:=xlSum, TopRow:=True, LeftColumn:=True
        .Columns(2).Insert
        .Columns(1).TextToColumns DataType:=xlDelimited, Tab:=True, Other:=False
        .Cells(1).CurrentRegion.Rows(1).NumberFormat = "yyyy年m月"
        .Copy ThisWorkbook.Sheets(1)
    End With

    wb.Close False

 End Sub

(マナ) 2019/03/16(土) 20:10


もし、こんなケースがあるなら、↑の統合機能は使えませんので無視してください。

>ElseIf (n + x) >= Rows.Count Then

(マナ) 2019/03/16(土) 20:33


問題がありました。

1)最後に、1行目で並べ替えの追加が必要でした。
2)どのCSVにもない年月は、統合後の表でも、その年月が欠落する。

今の段階で、修正しちゃうと
焦点がぼやけて、質問者さんは理解できない恐れがあるので
あえてコードは提示しませんが、
最終的には、こんな感じが良い気がします。

1)CSVをシートに取り込む
2)その際に、年月の最小値、最大値を更新しながら記憶
3)統合先の1行目に、最小値から最大値までの見出し作成
4)統合実行

(マナ) 2019/03/17(日) 11:36


 別案でも良ければ、

 Sub test()
     Dim myDir As String, fn As String, e, x(), n As Long, maxRow As Long
     Dim txt As String, ff As Long, AL As Object
     With Application.FileDialog(msoFileDialogFolderPicker)
         .InitialFileName = CreateObject("WScript.Shell").specialfolders("desktop")
         If .Show Then myDir = .SelectedItems(1) & "\"
     End With
     If myDir = "" Then Exit Sub
     Set AL = CreateObject("System.Collections.ArrayList")
     fn = Dir(myDir & "\*.csv")
     Do While fn <> ""
         n = n + 1: ReDim Preserve x(1 To 2, 1 To n)
         txt = Space(FileLen(myDir & fn))
         ff = FreeFile
         Open myDir & fn For Binary As #ff
             Get #ff, , txt
         Close #ff
         x(1, n) = Split(txt, vbCrLf): x(2, n) = fn
         For Each e In Split(x(1, n)(0), ",")
             If Trim$(e) <> "" Then
                 If Not AL.Contains(Trim$(e)) Then AL.Add Trim$(e)
             End If
         Next
         maxRow = maxRow + UBound(x(1, n)) + 1
         fn = Dir
     Loop
     If n = 0 Then MsgBox "No csv file in" & vbLf & """" & myDir & """", vbInformation: Exit Sub
     GetOutPut x, AL, Sheets("sheet2"), maxRow
 End Sub

 Private Sub GetOutPut(x, AL As Object, ws As Worksheet, maxRow As Long)
     Dim a, i As Long, ii As Long, iii As Long, xx, y, myMonth
     Dim dic As Object, e, n As Long
     ReDim a(1 To maxRow, 1 To AL.Count + 3): n = 1
     a(n, 1) = "File Name": a(1, 2) = "Item"
     For ii = 0 To AL.Count - 1
         a(n, ii + 3) = AL(ii)
     Next
     For ii = 1 To UBound(x, 2)
         xx = x(1, ii): myMonth = Split(xx(0), ",")
         For i = 1 To UBound(xx)
             If Application.Clean(xx(i)) <> "" Then
                 y = Split(xx(i), ",")
                 n = n + 1
                 a(n, 1) = x(2, ii): a(n, 2) = y(0)
                 For iii = 1 To UBound(y)
                     a(n, AL.IndexOf_3(Trim$(myMonth(iii))) + 3) = y(iii)
                 Next
             End If
         Next
     Next
     With [a3].Resize(n, AL.Count + 3)
         .CurrentRegion.ClearContents
         .Value = a
         With .Offset(, 2).Resize(, .Columns.Count - 2)
             .Sort .Rows(1), Orientation:=2
         End With
         .EntireColumn.AutoFit
     End With
 End Sub

 一応ファイルをアップロード
http://firestorage.jp/download/a48b27ef589f41547d608516c85ef7b816a12cee
 ダウンロードパスワード 2848ny90
(seiya) 2019/03/17(日) 12:05

(マナ)様

お忙しい中、丁寧なご対応、誠にありがとうございました。
能力不足の中、お力添えいただき、重ねて御礼申し上げます。

また会社データで使用したい為、お返事が遅くなりましたこと、お詫びいたします。
大変失礼を致しました。

始めに、問題が解消致しましたので、ご報告になります。
またお問い合わせいただいた懸念事項には問題ございませんでしたので、あわせてご連絡致します。

>>懸念いただいていた状況はございません。
>>1.取りまとめファイルの項目行は、あらかじめ入力しておくのでしょうか?
  項目行はあらかじめのフォーマットには無い想定となります。
  まっさらなファイルに、CSVファイルにある項目行含め、取り込みたいと考えております。
>>2.csvファイルをそのままエクセルで(ブックとして)開くと問題が生じますか?
  CSVファイルはそのままの状態で、エクセルでブックとして開くことが可能になります。

修正いただいた内容で、ほぼ希望はかなっておりました。
アップロードいただいていたファイルは、
セキュリティの関係で別のPCで無いとダウンロードが出来ない為、
追って使用させていただきたいと考えております。

お力添え感謝いたします。
またそのような能力を他の方の為に発揮出来る事に、とてもうらやましく思います。
どうぞ引き続き、よろしくお願い申し上げます。
(ひまわり) 2019/03/18(月) 16:20


わたしに、ではなく、もこな2さん と seiyaさん ですね。
あと、マルチポスト先は、経緯を説明したうえで、閉じておいたほうがよいかと。

(マナ) 2019/03/18(月) 18:17


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.