[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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
1.取りまとめファイルの項目行は、あらかじめ入力しておくのでしょうか？
2.csvファイルをそのままエクセルで（ブックとして）開くと問題が生じますか？
※場合によっては、私の手には負えないかもしれないです。
（もこな２） 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
１）最後に、１行目で並べ替えの追加が必要でした。
２）どのCSVにもない年月は、統合後の表でも、その年月が欠落する。
今の段階で、修正しちゃうと
焦点がぼやけて、質問者さんは理解できない恐れがあるので
あえてコードは提示しませんが、
最終的には、こんな感じが良い気がします。
１）CSVをシートに取り込む
２）その際に、年月の最小値、最大値を更新しながら記憶
３）統合先の１行目に、最小値から最大値までの見出し作成
４）統合実行
（マナ） 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
（マナ） 2019/03/18(月) 18:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.