Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2711 / 13645 ツリー ←次へ | 前へ→

【66441】同一フォルダのファイルを1つに sagfacttine 10/9/4(土) 18:06 質問[未読]
【66443】Re:同一フォルダのファイルを1つに UO3 10/9/4(土) 18:52 発言[未読]
【66453】Re:同一フォルダのファイルを1つに sagfacttine 10/9/5(日) 0:02 お礼[未読]
【66444】Re:同一フォルダのファイルを1つに UO3 10/9/4(土) 19:27 回答[未読]
【66460】Re:同一フォルダのファイルを1つに UO3 10/9/5(日) 5:43 回答[未読]

【66441】同一フォルダのファイルを1つに
質問  sagfacttine  - 10/9/4(土) 18:06 -

引用なし
パスワード
   同一フォルダ(C:\Documents and Settings\All Users\Documents\test)にA.xlsとB.xlsとC.xlsがあります。この3つは全部「入力シート」という名前のシート1枚から構成されているんです。
やりたいことは、そのフォルダの中に、新規のZ.xlsというブックを作成して、そのブックが「A」、「B」、「C」という3つのシートからなるようにしたいのです。
各シートは、A.xls、B.xls、C.xlsの「入力シート」となるように。
次の流れでやってみたのですが、4の過程がうまくできません。
(質問の例ではA〜Cの3ブックなのですが、実際はもっとブックが多くしかも何枚あるかは毎回異なるからです)
すみませんが、やりかたを教えてもらえませんか。


○1.新規Z.xlsの作成
○2.A.xlsの「入力シート」をZ.xlsにコピー
○3.入力シートの名前をAにかえる
×4.2、3の処理をファイルの数だけ繰り返す
○5.Z.xlsを保存

※○:できた ×:できなかった

【66443】Re:同一フォルダのファイルを1つに
発言  UO3  - 10/9/4(土) 18:52 -

引用なし
パスワード
   ▼sagfacttine さん:

こんばんは。
コード案をアップする前に確認です。

>(質問の例ではA〜Cの3ブックなのですが、実際はもっとブックが多くしかも何枚あるかは毎回異なるからです)

・ブックがたくさんあるのはわかります。「何枚」というのはシートのことですか?
 つまり、シートは各1枚ではなくブックによって何枚あるかわからないということで
 いいのですか?
・できあがったブックをZ.xlsとして、そのフォルダに保存したとしましょう。
 次回、再実行すると、そのZ.xlsも、そのフォルダにあるわけで統合の対象に
 なりますが、そのあたりは、どうお考えですか?

【66444】Re:同一フォルダのファイルを1つに
回答  UO3  - 10/9/4(土) 19:27 -

引用なし
パスワード
   ▼sagfacttine さん:

とりあえずコード案をアップしておきます。
要件を誤解していたら言ってください。

Sub Sample()
Dim myFolder As String
Dim newName As String
Dim getBookName As String
Dim newBook As Workbook
Dim numSh As Long, i As Long
Dim okFlag As Boolean
 Application.ScreenUpdating = False
 myFolder = "C:\Documents and Settings\All Users\Documents\test" & "\"
 newName = "Z.xls"   '<=== 統合ブックのブック名
 Set newBook = Workbooks.Add
 numSh = Worksheets.Count
 getBookName = Dir(myFolder & "*.xls")
 Do While getBookName <> ""
  With Workbooks.Open(myFolder & getBookName)
   If Not IsError(Evaluate("入力シート!A1")) Then
    okFlag = True
    .Worksheets("入力シート").Copy after:=newBook.Worksheets(newBook.Worksheets.Count)
    With newBook
     .Worksheets(.Worksheets.Count).Name = getBookName & "_入力シート"
    End With
   Else
    MsgBox getBookName & "に入力シートがありません"
   End If
   .Close savechanges:=False
  End With
  getBookName = Dir()
 Loop
 Application.DisplayAlerts = False
 If okFlag Then
  For i = 1 To numSh
   newBook.Worksheets(1).Delete
  Next
  newBook.SaveAs myFolder & newName
  MsgBox "処理が終わりました"
 Else
  MsgBox "フォルダに対象ブックが存在しません"
 End If
 newBook.Close  '処理終了時に作成したブックを表示しときたい場合は、ここを削除。
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 Set newBook = Nothing
End Sub

【66453】Re:同一フォルダのファイルを1つに
お礼  sagfacttine  - 10/9/5(日) 0:02 -

引用なし
パスワード
   質問がわかりにくくてすみません。
それなのに、コードを書いてくださり感激です。
今となっては以下の補足に意味はないかもしれませんが、念のため。

>・ブックがたくさんあるのはわかります。「何枚」というのはシートのことですか?
> つまり、シートは各1枚ではなくブックによって何枚あるかわからないということでいいのですか?
⇒シートは1枚でブックがいくつあるかその度に異なるということでした。
分かりにくくて申し訳ありませんでした。

>・できあがったブックをZ.xlsとして、そのフォルダに保存したとしましょう。
> 次回、再実行すると、そのZ.xlsも、そのフォルダにあるわけで統合の対象に
> なりますが、そのあたりは、どうお考えですか?

⇒たしかにそのとおりです。2回目以降の操作ではZ.xlsが存在していることまで頭が回っていませんでした。
Z.xlsを削除してから、再度Z.xlsをつくるようにプログラムを作成しようと思います。

【66460】Re:同一フォルダのファイルを1つに
回答  UO3  - 10/9/5(日) 5:43 -

引用なし
パスワード
   ▼sagfacttine さん:

補足ありがとうございました。
アップ済みのコードはZ.xlsが存在していたら、それも対象になっちゃいましたが
対象外とする部分を追加しました。
(保存時は上書きになります。)

Option Explicit

Sub Sample()
Dim myFolder As String
Dim newName As String
Dim getBookName As String
Dim newBook As Workbook
Dim numSh As Long, i As Long
Dim okFlag As Boolean
 Application.ScreenUpdating = False
 myFolder = "C:\Documents and Settings\All Users\Documents\test" & "\"
 newName = "Z.xls"   '<=== 統合ブックのブック名
 Set newBook = Workbooks.Add
 numSh = Worksheets.Count
 getBookName = Dir(myFolder & "*.xls")
 Do While getBookName <> ""
  If getBookName <> newName Then
   With Workbooks.Open(myFolder & getBookName)
    If Not IsError(Evaluate("入力シート!A1")) Then
     okFlag = True
     .Worksheets("入力シート").Copy after:=newBook.Worksheets(newBook.Worksheets.Count)
     With newBook
      .Worksheets(.Worksheets.Count).Name = getBookName & "_入力シート"
     End With
    Else
     MsgBox getBookName & "に入力シートがありません"
    End If
    .Close savechanges:=False
   End With
  End If
  getBookName = Dir()
 Loop
 Application.DisplayAlerts = False
 If okFlag Then
  For i = 1 To numSh
   newBook.Worksheets(1).Delete
  Next
  newBook.SaveAs myFolder & newName
  MsgBox "処理が終わりました"
 Else
  MsgBox "フォルダに対象ブックが存在しません"
 End If
 newBook.Close  '処理終了時に作成したブックを表示しときたい場合は、ここを削除。
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 Set newBook = Nothing
End Sub

2711 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free