こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

下は複数のエクセルファイルを一つにするマクロですが、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

投稿日時 - 2016-12-22 11:14:06

QNo.9271466

困ってます

質問者が選んだベストアンサー

こんにちは
処理能力高い環境なんですね。
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
で、試してみて下さい。

投稿日時 - 2016-12-22 15:48:56

お礼

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

投稿日時 - 2016-12-22 16:06:53

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(6)

ANo.6

回答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」に置換しているわけです。

投稿日時 - 2016-12-22 16:54:37

お礼

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

投稿日時 - 2016-12-23 11:46:48

ANo.4

私の想像ですが、データが 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

投稿日時 - 2016-12-22 15:28:51

お礼

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

投稿日時 - 2016-12-22 15:47:53

ANo.3

> 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行を超えないようにご注意ください。

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

投稿日時 - 2016-12-22 13:47:05

ANo.2

こんにちは
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
こんな感じで出来ますか?

投稿日時 - 2016-12-22 12:27:15

お礼

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

投稿日時 - 2016-12-22 15:17:43

ANo.1

WB1.Close False

の上に

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

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

投稿日時 - 2016-12-22 12:02:03

お礼

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

投稿日時 - 2016-12-22 15:26:20

あなたにオススメの質問