複数のエクセルシートをまとめるマクロ

質問

下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。
よろしくお願いします。

Sub Sample()
Dim t As Single
Dim strPath As String
Dim strFileName As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngRowCount As Long 'A列に値が入っているデータ数

t = Timer

'まとめたいシート
Set WS2 = ThisWorkbook.Worksheets(1)
strPath = ThisWorkbook.Path
strFileName = Dir(strPath & "\*.xls*")
Do While strFileName <> ""
If strFileName <> ThisWorkbook.Name Then
Set WB1 = Workbooks.Open(strPath & "\" & strFileName)
Set WS1 = WB1.Worksheets(1)
With WS1.Range("A1")
lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row
If lngRowCount >= 1 Then
With .Resize(lngRowCount, 14).Offset(1)
.Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1)
End With
End If
End With
WB1.Close False
End If
strFileName = Dir
Loop

MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss")
End Sub

回答No.5

ushi2015 · ベストアンサー

こんにちは
処理能力高い環境なんですね。
Sub test()
　　Dim t As Single
　　Dim strPath As String
　　Dim strFileName As String
　　Dim WB1 As Workbook
　　Dim WS1 As Worksheet
　　Dim WS2 As String
　　Dim i As Long
　　Dim SaveDir As String
　　Dim ShellObj As Object
　　Dim j As Long

　　t = Timer

　　 SaveDir = "C:\temp\" & Format(Date, "yyyymmdd")

　　 If Dir(SaveDir, vbDirectory) = "" Then
　　　　MkDir SaveDir
　　End If

　　strPath = ThisWorkbook.Path

　　WS2 = strPath & "\test1222.csv"

　　strFileName = Dir(strPath & "\*.xls*")
　　Do While strFileName <> ""
　　　　If strFileName <> ThisWorkbook.Name And Not strFileName Like "*.lnk" Then
　　　　　　j = j + 1
　　　　　　Set WB1 = Workbooks.Open(strPath & "\" & strFileName)
　　　　　　Set WS1 = WB1.Worksheets(1)
　　　　　　WS1.Copy
　　　　　　ActiveWorkbook.SaveAs SaveDir & "\" & Format(Now(), "yyyymmdd hhmmss") & "_" & j & ".csv", xlCSV
　　　　　　ActiveWorkbook.Close False
　　　　　　WB1.Close False
　　　　End If
　　　　strFileName = Dir
　　Loop

　　 Set ShellObj = CreateObject("WScript.Shell")

　　 ShellObj.Run "CMD.EXE /C type """ & SaveDir & "\*.csv"" > """ & WS2 & """", 0, True

　　 Kill SaveDir & "\*.csv"
　　RmDir SaveDir

　　MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss")
End Sub
で、試してみて下さい。

お礼

早速ありがとうございます。今度はうまくいきました。動きがBeautifulです。美しいです。
PCスペックは高いです。

回答No.6

Prome_Lin

回答No.1です。

大変、申し訳ございませんでした。

WB1.SaveAs Filename:=strPath & "\" & Replace(WB1.Name, "xls", "csv"), FileFormat:="xlCSV"

でした。

先ほどのマクロは、自分自身を「csv」形式で保存してしまっていました。

「WB1.Name」で、「WB1」は、質問者が開いている

Set WB1 = Workbooks.Open(strPath & "\" & strFileName)

ですね。

そのファイルの名前が「WB1.Name」ですが、これには「xls」という拡張子も含まれているので、「Replace()」で、「xls」を「csv」に置換しているわけです。

お礼

「アプリケーション定義またはオブジェクト定義のエラーです」が追加した場所で出てしまいます。対処の仕方を教えていただけますか。

回答No.4

SI299792

私の想像ですが、データが 100万件を超えるということは、出力結果をエクセルでなくほかのプログラムで見るのか目的だと思いました。
ファイルに直接データを書き込むのがいいと思います。
'
Option Explicit
'
Sub Macro1()
'
　　Dim t As Date
　　Dim FileName As String
　　Dim Camma As String
　　Dim IY As Long
　　Dim IX As Integer
'
　　t = Timer
　　ChDir ThisWorkbook.Path
　　FileName = Dir("*.XLS*")
　　Open "OutPut.csv" For Output As #1
'
　　Do While FileName > ""
'
　　　　If FileName <> ThisWorkbook.Name Then
　　　　　　Workbooks.Open FileName
'
　　　　　　For IY = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　Camma = ""
'
　　　　　　　　For IX = 1 To Cells(IY, Columns.Count).End(xlToLeft).Column
　　　　　　　　　　Print #1, Camma; Cells(IY, IX);
　　　　　　　　　　Camma = ","
　　　　　　　　Next IX
　　　　　　　　Print #1,
　　　　　　Next IY
　　　　　　ActiveWorkbook.Close
　　　　End If
　　　　FileName = Dir
　　Loop
　　Close
　　t = Timer - t
　　MsgBox "まとめ処理をしました。処理時間 " & Format(t / 86400, "h:mm:ss")
'
End Sub

お礼

後想像の通りです。エクセルファイルを一旦まとめてアクセスに取り込みます。
実行してみましたが、動いてはおりますが、OutPutファイルがからのままです。修正点ご指示下さい。

回答No.3

tsubu-yuki

> 100万件を超えるため

なのにエクセルで頑張ろうとなさるのですね。
　　https://support.office.com/ja-jp/article/Excel-%E3%81%AE%E4%BB%95%E6%A7%98%E3%81%A8%E5%88%B6%E9%99%90-ca36e2dc-1f09-4620-b726-67c00b05040f

ま、1,048,576行を超えないようにご注意ください。

なお、ＣＳＶとして保存するときの云々は
　　　　ActiveWorkbook.SaveAs Filename:="パス\ファイル名.csv", _
　　　　　　　　　　　　　　　FileFormat:=xlCSV, CreateBackup:=False
「マクロの記録」機能を使うと、こんな感じに書かれます。

回答No.2

ushi2015

こんにちは
Sub test()
　　Dim t As Single
　　Dim strPath As String
　　Dim strFileName As String
　　Dim WB1 As Workbook
　　Dim WS1 As Worksheet
　　Dim WS2 As String
　　Dim i As Long
　　Dim SaveDir As String
　　Dim ShellObj As Object

　　t = Timer

　　SaveDir = "C:\temp\" & Format(Date, "yyyymmdd")

　　If Dir(SaveDir, vbDirectory) = "" Then
　　　　MkDir SaveDir
　　End If

　　strPath = ThisWorkbook.Path

　　WS2 = strPath & "\test1222.csv"

　　strFileName = Dir(strPath & "\*.xls*")
　　Do While strFileName <> ""
　　　　If strFileName <> ThisWorkbook.Name Then
　　　　　　Set WB1 = Workbooks.Open(strPath & "\" & strFileName)
　　　　　　Set WS1 = WB1.Worksheets(1)
　　　　　　WS1.Copy
　　　　　　ActiveWorkbook.SaveAs SaveDir & "\" & Format(Now(), "yyyymmdd hhmmss") & "_1.csv", xlCSV
　　　　　　ActiveWorkbook.Close False
　　　　　　WB1.Close False
　　　　End If
　　　　strFileName = Dir
　　Loop

　　Set ShellObj = CreateObject("WScript.Shell")

　　ShellObj.Run "CMD.EXE /C type """ & SaveDir & "\*.csv"" > """ & WS2 & """", 0, True

　　Kill SaveDir & "\*.csv"
　　RmDir SaveDir

　　MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss")
End Sub
こんな感じで出来ますか？

お礼

ありがとうございます。
しかし実行すると何度も「すでに同じファイルがあります」とメッセージが出て、OKを押し続けて終了すると、一番最後のファイルが書式がクリアーされた状態で開いているだけの状態になりました。合体はされていないようです。

回答No.1

Prome_Lin

WB1.Close False

の上に

WB1.SaveAs Filename:=strPath & "\" & Replace(ThisWorkbook.Name, "xls", "csv"), FileFormat:="xlCSV"

とすれば、「csv」ファイルとして書き出されますが、質問者のマクロを見ていると、「xls」しかないのですよね？

お礼

ありがとうございます。
しかし「アプリケーション定義またはオブジェクト定義のエラーです」となります。
追加した部分で止まっているようです。どうしたらよいか教えていただけると助かります。