Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7全般 : Excel 2010)
複数シートのデータを1枚のシートに集約させたいです
投稿日時: 17/09/20 10:39:45
投稿者: よしみゆ

 
 こんにちは。
 VBAについて、勉強し始めたばかりで
 記述の仕方をまだ勉強中ですので、
 お手数おかけしますが、既知の方がおられましたらご教授いただきたいです。
 
 同じブック内の複数のシートの情報を
 1枚のシートに集約させる方法(行ごと転記)を調べたところ
 下記サイトに記載があったので、動作をさせたら
 複数シートの2行目以降のデータが反映されることを確認しました。
 
 https://www.moug.net/tech/exvba/0040062.html
 
 そこで質問なのですが・・・(質問が多くてすみません)
 
 ・複数シートでなく、転記したいシートを指定するには
 【Sheets(Array("Sheet1", "Sheet2", "Sheet3"))】などと記載すればいいのでしょうか?
 記載するとしても、どの位置に書けばいいのかわかりません・・・。
 
 ・転記データを「2行目以降」でなく「5行目以降」などと設定したいのですが
 変更するには、どこの記述をどう変更すればいいのでしょうか。
 
 ・転記する範囲を「すべて」ではなく
 「ある列(たとえばA列)の最後の行」までとしたいのですが
 変更するには、どこの記述をどう変更すればいいのでしょうか。
 【For i =5 To Cells(Rows.Count,1).End(xlUo).Row】などの
 記述は見つけたのですが、記載場所、方法が不明です。
 
 たくさんの質問で申し訳ありませんが、
 わかる方がおられましたら、よろしくお願いします。

回答
投稿日時: 17/09/20 14:26:10
投稿者: 半平太

これで試してみてください。
 

Sub Sample()
    Dim sWS As Worksheet  'データシート(コピー元)
    Dim dWS As Worksheet  '集約用シート(コピー先)
    Dim lastRowA As Long
    
    Set dWS = Worksheets("AllData")
    
    '集約用シートの2行目以降を削除
    dWS.Range("A2:A" & dWS.Rows.Count).ClearContents
    
    '指定シートの5行目以降のデータを、集約用シートの末尾にコピー
    For Each sWS In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
        
            lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row
            
            If lastRowA >= 5 Then '5行目以降にデータがあれば転記
                sWS.Range("A5:A" & lastRowA).Copy _
                Destination:=dWS.Cells(dWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
    Next sWS
End Sub

回答
投稿日時: 17/09/20 14:30:11
投稿者: 半平太

>'集約用シートの2行目以降を削除
 
訂正
 '集約用シートの2行目以降をクリア

投稿日時: 17/09/20 15:13:59
投稿者: よしみゆ

 
 半平太さん
 お忙しいところ、回答いただきありがとうございます。
 
 お陰様で改善されてきましたが、
 「AllData」のシート(←転記先のシート)に
 「A列」のみしか入らなくなってしまいました。
 
 要望ばかりですみません。。。
 【追記の要望1】
 すべての列が追記されるようにしたいのですが
 ・・・(~_~Wink
 ちなみに、初期VBAではコピーされていました。
 
 また、転記するシートは
 記載いただいた感じで大丈夫なのですが
 【追記の要望2】
 「Sheet1〜Sheet5まで」などと指定できるものでしょうか。
 
 調べたところ、下記の記載が見つかりましたが、
 例によって、入れる場所が不明です。。(すみません)
 
******************************
Public Sub SheetsSelect()
 Dim i As Integer, j As Integer
 Dim k As Integer
 Dim SheetNames() As String
 i = 2
 j = 4
 ReDim SheetNames(i To j)
 For k = i To j
 SheetNames(k) = "Sheet" & k
 Next
 Sheets(SheetNames).Select
 End Sub
*****************************
 
 また、自分で
 「Sheet1」「Sheet2」→「売上1」「売上2」
 「5行目」→「3行目」として
 いただいたVBAをこねくってみました。
 
****************************
 
Sub 角丸四角形1_Click()
    Dim sWS As Worksheet 'データシート(コピー元)
    Dim dWS As Worksheet '集約用シート(コピー先)
    Dim lastRowA As Long
     
    Set dWS = Worksheets("AllData")
     
    '集約用シートの2行目以降を削除
    dWS.Range("A2:A" & dWS.Rows.Count).ClearContents
     
    '指定シートの3行目以降のデータを、集約用シートの末尾にコピー
    For Each sWS In Sheets(Array("売上1", "売上2","売上3"))
         
            lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row
             
            If lastRowA >= 3 Then '3行目以降にデータがあれば転記
                sWS.Range("A3:A" & lastRowA).Copy _
                Destination:=dWS.Cells(dWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
    Next sWS
End Sub
 
 何度もお手数おかけしますが
 わかる方おられましたら、ご教授願います。

回答
投稿日時: 17/09/20 22:19:21
投稿者: simple

横から失礼します。
  
・シートの指定は直接すればよろしいのでは?
  理解できないコードを無理矢理使うより、よほど健全です。
・また、転記元の列範囲も指定すればどうですか?
  
実験的にコードを実行させて間違えたとしても
別に爆発したりすることはないので、
元のブックは保存して置いて、なんどでも実験してみてはどうでしょうか。
  
ゴール間近まで来ている感じ。自力で解決できそうな感じがしますよ。

回答
投稿日時: 17/09/20 22:35:43
投稿者: 半平太

レスが付きにくくなったのかと思って、書き始めてしまった。
以下で試してみてください。
 

Sub Sample()
    Dim sWS As Worksheet  'データシート(コピー元)
    Dim dWS As Worksheet  '集約用シート(コピー先)
    Dim lastRowA As Long
    
    Set dWS = Worksheets("AllData")
    
    '集約用シートの2行目以降をクリア
    dWS.UsedRange.Offset(1, 0).ClearContents
    
    '指定シートの5行目以降のデータを、集約用シートの末尾にコピー
    
    For Each sWS In Sheets(ShNameAry("Sheet", 2, 4)) 
                  'Sheet2〜4 の場合、"Sheet"、2、4を引数に入れる

        lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row
        
        If lastRowA >= 5 Then '5行目以上にデータがあれば転記
            Intersect(sWS.Range("A5:A" & lastRowA).EntireRow, sWS.UsedRange).Copy _
                Destination:=dWS.Cells(dWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next sWS
End Sub

Private Function ShNameAry(ShName As String, i As Integer, j As Integer)
    Dim k As Integer
    Dim SheetNames() As String

    ReDim SheetNames(i To j)
    For k = i To j
        SheetNames(k) = ShName & k
    Next
    
    ShNameAry = SheetNames
End Function

投稿日時: 17/09/21 10:55:14
投稿者: よしみゆ

 おはようございます。
 simpleさん、半平太さん、ご回答ありがとうございます。
 
 すみません。細かいことなのですが…聞いてもいいでしょうか。
 
 半平太さんに書いていただいたマクロを実行すると
 1回目:貼り付けOK
 2回目:「2行目」と「3行目」に同じデータが入ってくる
     (その後、1行ずつ下がって記載される)
 …となります。
 
 <質問1>
 追記した
 【Intersect….EntireRow,sWS.UsedRange).Copy】の部分を直すのではと
 思うのですが、いかんせんどう直していいのか、助けていただきたいです。
 
 お時間があればで大丈夫なので、
 初心者ついでにもう少しお聞きしたいのですが…。
 
 今回、半平太さんに書いていただいたシート番号の記載は
 「Sheet」の部分は固定で、その後の番号が変更されても大丈夫というものでした。
 
 <質問2>変な話なのですが、シート名(シート名を変えればいいのですが・・・)が
 「29.4」「30.1」のようになると対応できない状態です。
 
 Private Functionの「ShNameAry」をもう1つ
 「SWNameAry」などとして、「k」を「m」などにして
 設定すればいいのでしょうか。
 また【For Each…】の部分に「SWNameAry」を追加するのでしょうか。。
 
 <質問3>このマクロを別ブックのボタンで操作するとすれば
 「画面更新しない」設定にして
 「Open」と「Close」させたいのですが
 そのための記述を探したところ、使い方が不明なので
 ご教授お願いしたいのです。
 
 【Dim…】の記述後ろに【Application,ScreenUodating = False】と
 入れればいいのでしょうか。
 また、下記「Open」設定をしたいのですが
 こうやって開いたブックを「Close」させる記述・場所が不明なので
 知っている方がおられましたら、ご教授お願いしたいです。
 
************************************************
※ファイル存在のチェックと
 ファイルが開いているかどうかのチェックをしてから
 開かせるマクロ
 
Dim buf As String, wb As Workbook
Const Target As String = "C:\Book1.xlsx"
buf = Dir(Target) ''ファイル存在のチェック
If bur = ""Then
 MsgBox Target & vbCrLf & "は存在しません",vbExclamation
 Exit Sub
End If
For Each wb In Workbooks''同名ブックのチェック
 If wb.Name = buf Then
 MsgBox buf & vbCrLf &"はすでに開いています",vbExclamation
 Exit Sub
 End Sub
Next wb
Workbooks.Open Target''ここでブックを開く
End Sub
 
************************************************
 
 貴重なお時間いただき、ありがとうございます。
 お手間おかけしますが、返信いただければ幸いです。

投稿日時: 17/09/21 10:58:33
投稿者: よしみゆ

 おはようございます。
 simpleさん、半平太さん、ご回答ありがとうございます。
 
 すみません。細かいことなのですが…聞いてもいいでしょうか。
 
 半平太さんに書いていただいたマクロを実行すると
 1回目:貼り付けOK
 2回目:「2行目」と「3行目」に同じデータが入ってくる
     (その後、1行ずつ下がって記載される)
 …となります。
 
 <質問1>
 追記した
 【Intersect….EntireRow,sWS.UsedRange).Copy】の部分を直すのではと
 思うのですが、いかんせんどう直していいのか、助けていただきたいです。
 
 お時間があればで大丈夫なので、
 初心者ついでにもう少しお聞きしたいのですが…。
 
 今回、半平太さんに書いていただいたシート番号の記載は
 「Sheet」の部分は固定で、その後の番号が変更されても大丈夫というものでした。
 
 <質問2>変な話なのですが、シート名(シート名を変えればいいのですが・・・)が
 「29.4」「30.1」のようになると対応できない状態です。
 
 Private Functionの「ShNameAry」をもう1つ
 「SWNameAry」などとして、「k」を「m」などにして
 設定すればいいのでしょうか。
 また【For Each…】の部分に「SWNameAry」を追加するのでしょうか。。
 
 <質問3>このマクロを別ブックのボタンで操作するとすれば
 「画面更新しない」設定にして
 「Open」と「Close」させたいのですが
 そのための記述を探したところ、使い方が不明なので
 ご教授お願いしたいのです。
 
 【Dim…】の記述後ろに【Application,ScreenUpdating = False】と
 入れればいいのでしょうか。
 また、下記「Open」設定をしたいのですが
 こうやって開いたブックを「Close」させる記述・場所が不明なので
 知っている方がおられましたら、ご教授お願いしたいです。
 
************************************************
※ファイル存在のチェックと
 ファイルが開いているかどうかのチェックをしてから
 開かせるマクロ
 
Dim buf As String, wb As Workbook
Const Target As String = "C:\Book1.xlsx"
buf = Dir(Target) ''ファイル存在のチェック
If bur = ""Then
 MsgBox Target & vbCrLf & "は存在しません",vbExclamation
 Exit Sub
End If
For Each wb In Workbooks''同名ブックのチェック
 If wb.Name = buf Then
 MsgBox buf & vbCrLf &"はすでに開いています",vbExclamation
 Exit Sub
 End Sub
Next wb
Workbooks.Open Target''ここでブックを開く
End Sub
 
************************************************
 
 貴重なお時間いただき、ありがとうございます。
 お手間おかけしますが、返信いただければ幸いです。

回答
投稿日時: 17/09/21 17:40:56
投稿者: 半平太

> 1回目:貼り付けOK
> 2回目:「2行目」と「3行目」に同じデータが入ってくる
>     (その後、1行ずつ下がって記載される)
> …となります。
 
ふーむ、こちらでは再現しないです。
 
元々、データの在り様について説明がないので、こちらでは
単純なサンプルでしかテストしておりませんけども・・
 
こちらで再現できるテストデータを提示頂かない限り、
この件はこれ以上の進展はありません。
 
> <質問2>
> 「29.4」「30.1」のようになると対応できない状態です。
 
当然です。
今までの説明が Sheet1〜Sheet3 などと言うケースですからねぇ。
 
・・と言っても、今度はどう対応すれば満足なのか、
その説明がなければ、この件もこれ以上の進展はありません。
 
> <質問3>このマクロを別ブックのボタンで操作するとすれば
 
今回、別ブックのマクロから操作すると言う想定はしておりませんので、
私のコードを使うと、ちょっとリスキーな状態になります。
 
本当にそうするお積りなら、「知っている方」のレスをお待ちください。
私はこれ以上深入りいたしません。

回答
投稿日時: 17/09/22 07:34:17
投稿者: mattuwan44

>記述の仕方をまだ勉強中ですので
 
あのですね。
一般論ではなかなか、解決しないと思うんですよ。
 
興味ある実例(いま取り組んでいることがら)をやっていくのが一番早いでしょう。
でも、回答者はあなたのパソコンが見れません。
 
前提条件とやりたいこと。そして、最終結果。
これをまず決める。これが重要でしょう。
そして、次に結果が得られる方法論、つまり作業の流れを書き出す。
それが出来れば、
日本語を1行1行VBA語に変換・翻訳していくだけです。
 
前提条件としては、
マクロを書いてあるブックから別のブックを開きそのブックからデータを取り出して、
どこかに転記なんですかね?
その辺の説明からしてはいかがでしょうか?

投稿日時: 17/09/22 16:34:56
投稿者: よしみゆ

 
 半平太さん、mattuwan44さん
 返信ありがとうございます。
 
 説明不足ですみません。
 構想としては…
 1.同じフォルダ内に「Book1.xltm」「Book2.xltm」を置いて
 2.「Book1」内にある12ヶ月分の月ごとのシートを随時更新していき
  そのシート内容すべてを「Book1」内の「All Data」というシートに入れて
 「AllData」シートから
 「Book2」にある企業ごとのシートに、データを振分けする予定なので
 できれば「Book1」を開いて集計させるのではなく、
 「Book2」にボタンを置きたいのです。
 
 3.今は「Book1」の12ヶ月分のデータを随時「Book1」内の
 「AllData」シートに移すマクロを完成させたいと思っています。
 
 〜「Book1」の内容〜
 ↓のような情報が入っているシートが
 「29.4」「30.1」のシート名で並んでいる
 
   A  B    C     D    E
5 日付 顧客  品目    単価  数量
6 4/1 BB電機 VVFケーブル 2000  10

(最後の行数は月によってバラバラ・各シート1〜4行目は別情報有り)
 
 半平太さんが作ってくださったマクロを実行すると、
 「AllData」内に入るデータが
 1回目実行:2シートが集約されて表示された(OK)
 2回目実行:最初のシートの5行目が
 AllDataシートの2・3行目に2重に表示されてしまいます。
 
 また、せっかく連続してシート名を設定できるVBAを
 書いていただいたのですが
 「29.4」の他に「30.1」などもシート名で入ってくるため
 (2種類のシート名を設定する方法が、自分の知識不足でわからず)
 「Array」のほうで再度書かせていただこうかと思っています。
 
 私のやりたいことをやろうとすると、
 もしかして、最初から
 組み直しになってしまうのでしょうか。
 
 「画面の更新をしない」
 (Application,ScreenUpdating=False)と
 下記「Open」をして「Close」(←Closeは記述不明)
 させる記述をしたいのですが…
 
 
Dim buf As String, wb As Workbook
 Const Target As String = "C:\Book1.xltm"
 buf = Dir(Target) 'ファイル存在のチェック
If bur = ""Then
  MsgBox Target & vbCrLf & "は存在しません",vbExclamation
  Exit Sub
 End If
 For Each wb In Workbooks '同名ブックのチェック
 If wb.Name = buf Then
  MsgBox buf & vbCrLf &"はすでに開いています",vbExclamation
  Exit Sub
  End Sub
 Next wb
 Workbooks.Open Target''ここでブックを開く
End Sub
 
 お忙しいところ、お手間おかけしております。
 時間がありましたら、対応をお願いします。

回答
投稿日時: 17/09/22 16:38:09
投稿者: 半平太

> 半平太さんが作ってくださったマクロを実行すると、
> 「AllData」内に入るデータが
> 1回目実行:2シートが集約されて表示された(OK)
> 2回目実行:最初のシートの5行目が
> AllDataシートの2・3行目に2重に表示されてしまいます。
 
よく分からないですねぇ。
 
何で2シートなんですか?
私が書いたのは3シート分ですよ?
 
そっちで適当にプログラムを修正していないですか?
 
もし、そちらで修正したものが旨く動かないなんて話なら、
どう修正したのか説明がないと、私の関知できることではないですけど。
再現テストだって出来ないですよ?

投稿日時: 17/09/22 17:14:31
投稿者: よしみゆ

 半平太さん返信ありがとうございます。
 
 何度やってみても、
 「最初に指定したシート」の2行目が
 「AllData」の2・3行目に同じく
 表示されるのですが…。
 
 2シートでも3シートでも
 こちらでやると同じ現象です。。
 
 この掲示板はファイル添付できないので
 実物をお送りできないところが歯がゆいのですが。。

回答
投稿日時: 17/09/22 18:26:39
投稿者: 半平太

このテストで使っている実際のコードをアップしてください。

回答
投稿日時: 17/09/23 11:01:15
投稿者: mattuwan44

> 私のやりたいことをやろうとすると、
> もしかして、最初から
> 組み直しになってしまうのでしょうか。

 
記述の仕方をまだ勉強中なのですから、何度でも書き直して覚えるしかないのでは?
 
作業の流れとしては、
1)データベースとして使用するファイルが所定の位置にあるか確認してあれば開く(変数に保持)
2)(データベースとして利用できるように)開いたブックの集約シートに他のシートのデータを転記・集約
3)データベースから自ブックの取引先シート毎にデータを抽出する
4)開いたデータベースファイルを(保存をせずに)閉じる
こういうことですね?
 
1)の作業をもう少し細分化して表現してみる
1-1)既定のファイルを開いてみる(存在すれば開いたファイルを変数に代入)
1-2)存在しなければエラーとなるので回避して終了
 
2)の作業は
2-1)開いたブックの集約シートの初期化
2-2)開いたブックのシート群を巡回して作業を繰り返す
2-3)もし、対象のシートが集約シートでないなら、データを集約シートに転記
2-4)次へ
 
3)の作業は
3-1)自ブックのシート群を巡回して作業を繰り返す
3-2)シートの初期化
3-3)シート名の取得
3-4)取得した名前で、データベースシート(開いたファイルのデータ集約シート)から抽出
3-5)もし、1件以上データがあれば、対象シートに転記
3-6)次へ
 
上記を疑似コードで書いてみると、

Sub 取引先別でシート毎に抽出()

    '1)データベースとして使用するファイルが所定の位置にあるか確認してあれば開く(変数に保持)
        '1-1)既定のファイルを開いてみる(存在すれば開いたファイルを変数に代入)
        '1-2)存在しなければエラーとなるので回避して終了
        '
    '2)(データベースとして利用できるように)開いたブックの集約シートに他のシートのデータを転記・集約
        '2-1)集約シートの初期化
        '2-2)開いたブックのシート群を巡回して作業を繰り返す
            '2-3)もし、対象のシートが集約シートでないなら、データを集約シートに転記
        '2-4)次へ
        '
    '3)データベースから自ブックの取引先シート毎にデータを抽出する
        '3-1)自ブックのシート群を巡回して作業を繰り返す
            '3-2)対象シートの初期化
            '3-3)対象シート名の取得
            '3-4)取得した名前で、データベースシート(開いたファイルのデータ集約シート)からデータを抽出
            '3-5)もし、1件以上データがあれば、対象シートに転記
        '3-6)次へ

    '4)開いたデータベースファイルを(保存をせずに)閉じる
    
End Sub

こんな風になると思います。
あとは、1行1行をVBA語に変換・翻訳していきます。
Option Explicit

Sub 取引先別でシート毎に抽出()
'定数の宣言
    Const cMyFileName As String = "C:\Book1.xlsx"
    Const cMySheetName As String = "AllData"
    '変数の宣言
    Dim wbData As Workbook
    Dim ws As Worksheet
    Dim rngTo As Range
    Dim rngFrom As Range
    Dim sName As String

    '1)データベースとして使用するファイルが所定の位置にあるか確認してあれば開く(変数に保持)
    '1-1)既定のファイルを開いてみる(存在すれば開いたファイルを変数に代入)
    On Error Resume Next
    wbData = Workbooks.Open(cMyFileName)
    On Error GoTo 0
    '1-2)存在しなければエラーとなるので回避して終了
    If wbData Is Nothing Then Exit Sub
    '
    '2)(データベースとして利用できるように)開いたブックの集約シートに他のシートのデータを転記・集約
    '2-1)集約シートの初期化
    Set rngTo = wbData.Sheets(cMySheetName).Range("A6")
    With rngTo.CurrentRegion
        Application.Range(rngTo, .Cells(.Count)).ClearContents
    End With
    '2-2)開いたブックのシート群を巡回して作業を繰り返す
    For Each ws In wbData.Worksheets
        '2-3)もし、対象のシートが集約シートでないなら、データを集約シートに転記
        If ws.Name <> cMySheetName Then
            Set rngFrom = ws.Range("A6")
            With rngFrom.CurrentRegion
                With Application.Range(rngFrom, .Cells(.Count))
                    'コピペ
                    .Copy rngTo
                    '次の転記先を用意
                    Set rngTo = rngTo.Offset(.Rows.Count)
                End With
            End With
        End If
    '2-4)次へ
    Next

    '
    '3)データベースから自ブックの取引先シート毎にデータを抽出する
    '3-1)自ブックのシート群を巡回して作業を繰り返す
    For Each ws In ThisWorkbook.Worksheets
        '3-2)対象シートの初期化
        With ws.UsedRange
            Intersect(.Cells, .Offset(5)).ClearContents
        End With
        '3-3)対象シート名の取得
        sName = ws.Name
        '3-4)取得した名前で、データベースシート(開いたファイルのデータ集約シート)からデータを抽出
        With wbData.Sheets(cMySheetName).Range("A6").CurrentRegion
            Set rngFrom = Intersect(.Cells, .Offset(4))
        End With
        rngFrom.AutoFilter Field:=2, Criteria1:=sName
        '3-5)もし、1件以上データがあれば、対象シートに転記
        If rngFrom.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
            rngFrom.Offset(1).Copy ws.Range("A6")
        End If
    '3-6)次へ
    Next

    '4)開いたデータベースファイルを(保存をせずに)閉じる
    wbData.Close False
End Sub

 
書きながら付け足した部分がありますが、
おおむねこのような流れでコードを書いていくといいと思います。
で、たぶん上級者でも、なかなか1発で思い通りの結果は得られないと思います。
例えば↓このようなこと。
> 2回目:「2行目」と「3行目」に同じデータが入ってくる
 
こういう場合は、意図したセル範囲がちゃんと取得できているか、
メッセージボックスにセルのアドレスを表示させてみたり、
ステップ実行をしながら、セルの選択をして目視で確認したり、
変数の中身をウォッチウィンドウで確認しながら、
デバッグをしていくことになります。
 
提示したコードは動作確認をしておりません。
参考程度にご使用するなりデバッグするなりしてみて勉強してみてください。
対象のセル範囲をいかにして特定するか。ここが肝だとぼくは思います。
 
こちらは時間が取れないので、次いつ掲示板を見るかわかりませんので、
ご了承ください。

回答
投稿日時: 17/09/23 16:31:13
投稿者: 菊りん0828

こんにちは
参加させて下さい
 
>構想としては…
>3.今は「Book1」の12ヶ月分のデータを随時「Book1」内の
>「AllData」シートに移すマクロを完成させたいと思っています。
 
Book1 に何枚のシートがあるのか判りませんが、
「Book1」内の「AllData」以外のシートが転記対象であるならば
 
'----------------------------------------------
●Book1 = ThisWorkBook とした場合・・・
 
Sub Test()
   Dim LngA As Long
   Dim TrgB As Excel.Workbook
    
   Set TrgB = ThisWorkbook
   For LngA = 1 To TrgB.Sheets.Count
      If TrgB.Sheets(LngA).Name <> "AllData" Then
         MsgBox TrgB.Sheets(LngA).Name '←←ここ
      End If
   Next
   Set TrgB = Nothing
End Sub
 
ブック内の左側から順に
MsgBox に表示に表示されたシート名が転記元シートとなると思います
 
'----------------------------------------------
ご質問、冒頭の
>変更するには、どこの記述をどう変更すればいいのでしょうか。
>【For i =5 To Cells(Rows.Count,1).End(xlUo).Row】などの
>記述は見つけたのですが、記載場所、方法が不明です。
 
例えばこんな風に書くと思います ↓
(上記コードの「←←ここ」の部分を以下と書き換えて下さい)
 
 With TrgB.Sheets(LngA)
   For LngI = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row
      .Activate '動作確認のため
      .Cells(LngI, 1).Select '動作確認のため
      MsgBox "" '動作確認のため
   Next
End With
 
しかし、このコードでは「1行」ずつ転記しなければなりません。
更に、カウンタ変数(LngI) が 5 から始まっているので、シート枚数分
列見出しを転記することになってしまいます
 
違っていたらすいません
 
m(_ _)m ぺこり

投稿日時: 17/09/25 15:12:50
投稿者: よしみゆ

 半平太さん・mattuwan44さん・菊りん0828さん
 返信ありがとうございます。
 
 不甲斐ない質問者ですみません。
 結構な記述になるようで、見ただけでびっくりしてしまいました。
 
 私の思っていることをもう少し詳しく記述すると
 「Book2」に置く予定のボタンは
 1.「Book1」の各シートを「Book1のAllDataシート」に移すボタン【今回質問していること】
 2.「Book1のAllDataシート」から「Book2の企業別各シート」へ移すボタン…と
 上記の2つにしようと思っています。
 
 なぜなら、
 別ブック(年度の違うデータ)が増えた場合、同じ記述をしたり
 後で手直ししたり…を考えると、別記載にしたほうが安心(?)だと思ったので。。
 
 ですので、できましたら「企業別シートにわけること」は
 今はとりあえず、考えないでいただきたいのです。
 
 半平太さん、私が記述しているコードは、下記コードです。
 >For Each sWS In Sheets(ShNameAry("29.", 4, 6))
 の部分を
 >For Each sWS In Sheets(Array("29.4", "29.5", "29.6"))
 としても、どちらにしても「AllData」で更新されるデータが
 「2行目以降」でなくて「3行目以降」となっています。
 (2行目は、最初に記載された「29.4シート」の5行目がそのまま記載)
 (ちなみに「AllData」以外のすべてのシートというくくりも
  範囲指定としては難しいので、今回はArrayを使おうかと思っています)
 
 

  Sub 角丸四角形1_Click()
    Dim sWS As Worksheet  'データシート(コピー元)
    Dim dWS As Worksheet  '集約用シート(コピー先)
    Dim lastRowA As Long
    
    Set dWS = Worksheets("AllData")
    
    '集約用シートの2行目以降をクリア
    dWS.UsedRange.Offset(1, 0).ClearContents
    
    '指定シートの5行目以降のデータを、集約用シートの末尾にコピー
    
    For Each sWS In Sheets(ShNameAry("29.", 4, 6))
                                    'Sheet2〜4 の場合、"Sheet"、2、4を引数に入れる

        lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row
        
        If lastRowA >= 5 Then '5行目以上にデータがあれば転記
            Intersect(sWS.Range("A5:A" & lastRowA).EntireRow, sWS.UsedRange).Copy _
                Destination:=dWS.Cells(dWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next sWS
End Sub

Private Function ShNameAry(ShName As String, i As Integer, j As Integer)
    Dim k As Integer
    Dim SheetNames() As String

    ReDim SheetNames(i To j)
    For k = i To j
        SheetNames(k) = ShName & k
    Next
    
    ShNameAry = SheetNames
End Function

 
 上記コードで少し手直しできて
 (最悪、AllDataのシートは
 誰も見ないと思うので、そのままの記述でいこうかと思っています)
 
 画面表示更新をせずに「Book2」にボタンを置いて
 「Book1」を「Open」「Close」させるコードについて
 アドバイスいただければ
 超初心者の私としては、うれしいです。
 
 開きたいBookを別の人が開いている時等にはエラーを返す
 下記コードを発見したのですが、Closeのさせ方が不明なのです。
 
 ブック表示を更新しない
 「Application,ScreenUpdating=False」を入れて
 
 ブックを閉じる際に「保存しない」にしたいのですが
 (「Target.Close SaveChanges:=False」と記載したいのです)
 どう記載してよいやら、戸惑っています。。
 
  Sub Sample1()
    Dim buf As String, wb As Workbook
    Const Target As String = "C:\Book1.xlsx"
    ''ファイルの存在チェック
    buf = Dir(Target)
    If buf = "" Then
        MsgBox Target & vbCrLf & "は存在しません", vbExclamation
        Exit Sub
    End If
    ''同名ブックのチェック
    For Each wb In Workbooks
        If wb.Name = buf Then
            MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
            Exit Sub
        End If
    Next wb
    ''ここでブックを開く
    Workbooks.Open Target
End Sub

 
 みなさま、お騒がせしてすみません。
 お手数おかけしますが、ご教授お願いしたいです

回答
投稿日時: 17/09/25 23:33:50
投稿者: 半平太

>半平太さん、私が記述しているコードは、下記コードです。
>>For Each sWS In Sheets(ShNameAry("29.", 4, 6))
 
右下のサンプルデータで、そのコードを実行すると下の結果図になります。
そっちではそうならないのですか?
 

<AllData 結果図>                <29.4 サンプル>
 行 ___A___ ___B___ _____C_____ ___D___ __E__   行 ___A___ ___B___ _____C_____ __D__  __E__
  1 項目                                         5  日付    顧客    品目       単価   数量 
  2 日付    顧客    品目        単価    数量     6  4月1日  AA電機  VVFケーブル1000     40 
  3 4月1日  AA電機  VVFケーブル   1000    40 
  4 日付    顧客    品目        単価    数量   <29.5 サンプル>
  5 10月1日 BB電機  VVFケーブル  20000    51    行 ___A___ ___B___ _____C_____ __D__  __E__
  6 11月1日 BBC電池 VHS          20000    52     5 日付    顧客    品目        単価   数量 
  7 12月1日 BB湯浅  ワイヤー     20000    53     6 10月1日 BB電機  VVFケーブル 20000    51 
  8 日付    顧客    品目        単価    数量     7 11月1日 BBC電池 VHS         20000    52 
  9 12月1日 BB電機  VVFケーブル 300000    61     8 12月1日 BB湯浅  ワイヤー    20000    53 
 10 1月1日  BBC電池 VHS         300000    62 
                                               <29.6 サンプル>
                                               行 ___A___ ___B___ _____C_____ ___D___ __E__
                                                5 日付    顧客    品目        単価    数量 
                                                6 12月1日 BB電機  VVFケーブル 300000    61 
                                                7 1月1日  BBC電池 VHS         300000    62 

・・とお聞きした所で、もう継続は難しいです。
 
横からごちゃごちゃしたものが入って来たし、
別ブックのマクロでの操作と言う方針になっているので、
私は、ここでドロップアウトします。 m(__)m

投稿日時: 17/09/26 13:50:05
投稿者: よしみゆ

 
 半平太さん
 返信ありがとうございました。
 
 <AllData 結果図>でいくと、1度目の実行で
 半平太さんが記載してくれた、そのままの結果になります。
 
 2回目の実行をすると
 2行目の「日付 顧客 品目 単価 数量」が
 「3行目」に同じく記載されてきます。
 特に誰に見せるでもないので、そのままで使用させていただきます。
 
 私のわがままな要望におつきあいくださり
 サポートいただき、ありがとうございました。
 大変助かりました。
 
 すみません。
 わがままついでに、もう1つ確認事項があるのですが…
 「A列の最後行」でなくて「B列の最後行」に指定するには
 
 「lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row」を
 「lastRowB = sWS.Cells(sWS.Rows.Count, "B").End(xlUp).Row」と変える以外に
 変更部分がありましたでしょうか。
 
 できましたら、
 その場合の変更箇所を教えていただきたいのですが。。
 
 また、もし「Open」「Close」のわかる方がおられましたら
 お知らせをお願いします。

回答
投稿日時: 17/09/26 21:06:21
投稿者: simple

横から失礼します。
(1)
一回目と二回目で結果が違うという話は、
AllDataシートの一行目が一度も使っていない(何も入力していない)ことが原因と想像。
このため、UsedRange が 2行目以下を指しているんでしょう。
 
A1セルに"項目"でも何でも入れれば、一行目からUsedRangeとなり、
不審な?動きはやむものと思います。
 
(2)
ボタンを置くBook2の標準モジュールに今作成中のコードを移して、
そのマクロから、Book1を操作(open、シート間の転記、保存、close)すれば
よろしいかと思います。
 
参考コード例(変更した行には、■をつけています。)を示します。
 

Sub 角丸四角形1_Click()
    Dim sWS As Worksheet  'データシート(コピー元)
    Dim dWS As Worksheet  '集約用シート(コピー先)
    Dim lastRowA As Long
    Dim wb As Workbook    ' ■■■

    Set wb = Workbooks("C:\Book1.xlsx") '■ 要修正
    Set dWS = wb.Worksheets("AllData")  '■

    '集約用シートの2行目以降をクリア
    dWS.UsedRange.Offset(1, 0).ClearContents

    '指定シートの5行目以降のデータを、集約用シートの末尾にコピー

    For Each sWS In wb.Sheets(ShNameAry("29.", 4, 6)) '■
        'Sheet2〜4 の場合、"Sheet"、2、4を引数に入れる

        lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row

        If lastRowA >= 5 Then    '5行目以上にデータがあれば転記
            Intersect(sWS.Range("A5:A" & lastRowA).EntireRow, sWS.UsedRange).Copy _
                    Destination:=dWS.Cells(dWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next sWS
    
    wb.Save                  '■■■
    wb.Close False           '■■■
End Sub
Private Function ShNameAry(ShName As String, i As Integer, j As Integer)
    Dim k As Integer
    Dim SheetNames() As String

    ReDim SheetNames(i To j)
    For k = i To j
        SheetNames(k) = ShName & k
    Next

    ShNameAry = SheetNames
End Function

詳細な検証はしていません。よくチェックしてい下さい。
また、画面更新の抑止だとか枝葉部分はそちらでどうぞ。
 
# ちなみに、
# >横からごちゃごちゃしたものが入って来たし、
# それはあんまりかと。
# スクラッチで取り組んで欲しいという助言でしょう。
# 色々な助言があってよいはずだと思いました。
# その目的から、少し説明的になりすぎているきらいはありますが。
# 私は、それに対する質問者さんの反応にがっかりでした。

回答
投稿日時: 17/09/27 17:12:55
投稿者: mattuwan44

>ですので、できましたら「企業別シートにわけること」は
> 今はとりあえず、考えないでいただきたいのです。

 
でしたらこういう流れですよね?

Option Explicit

Sub シートの集約()
    Dim wbDataBase As Workbook
    Dim wsResult As Worksheet
    Dim ws As Worksheet
    Dim sProm As String

    'データベースとして使うブックの取得
    On Error GoTo ErrH
    Set wbDataBase = Workbooks.Open("C:\Book1.xlsx")
    On Error GoTo 0

    'データベースとして使うシートの取得(複数シートに分かれているものを一つにまとめる用)
    On Error GoTo ErrH2
    Set wsResult = wbDataBase.Sheets("AllData")
    On Error GoTo 0

    '指定のブックやシートが無ければメッセージを出してプログラム終了
    If Len(sProm) > 0 Then
        MsgBox sProm
        Exit Sub
    End If

    '集約シートの初期化
    wsResult.UsedRange.Offset(1).ClearContents

    '開いたブックの各シートを巡回する
    For Each ws In wbDataBase.Worksheets
        'もし、集計シート以外ならデータを集計シートの最後のデータの下にコピペ
        If Not ws Is wsResult Then
            ws.UsedRange.Offset(1).Copy _
                    wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next

    '開いたブックを上書きしないで閉じる
    wbDataBase.Close False

    'プログラム終わり
    Exit Sub

    'エラー処理
    'ブックが無い場合
ErrH:
    sProm = "既定のブックがありません。管理者に確認してください。"
    Resume Next

    'シートが無い場合(ブックが無い場合は当然シートもないのでそこは回避)
ErrH2:
    If wbDataBase Is Nothing Then
        sProm = "指定のシートがありません。管理者に確認してください。"
    End If
    Resume Next
End Sub

 
> ブック表示を更新しない
> 「Application,ScreenUpdating=False」を入れて
  
> ブックを閉じる際に「保存しない」にしたいのですが
> (「Target.Close SaveChanges:=False」と記載したいのです)
> どう記載してよいやら、戸惑っています。。

その操作をしたいときに実行するよう書けばいいだけでは?
 
ステップ実行を試してみることをお勧めします。
http://www.ken3.org/vba/excel-help.html
 
> 開きたいBookを別の人が開いている時等にはエラーを返す
話しがとりとめもなくて、いま、どうなっていて何に困っているかが解らない上に、
次々と新しい要件が出てきてますね。
作っていると、回答を待つ間に
「ああしたい。こうしたい。」となるのは解りますが、
一つづつ片付けて行った方がいいように思います。

回答
投稿日時: 17/09/27 17:16:30
投稿者: mattuwan44

>2回目の実行をすると
> 2行目の「日付 顧客 品目 単価 数量」が
> 「3行目」に同じく記載されてきます。
> 特に誰に見せるでもないので、そのままで使用させていただきます。

コピー元か貼付先のセル範囲の指定の仕方(あるいは手順)がまずくてそうなるのでしょう。
 
ステップ実行しながら、
セルの選択をするコードを挟み込んで可視化してデバッグすると
解ると思います。

投稿日時: 17/10/05 09:48:59
投稿者: よしみゆ

 半平太さん・simpleさん・mattuwan44さん
 返信遅くなりすみません。(別件で忙しくしていました)
 サポートいただき、大変ありがとうございました。
 
 2・3行目に項目が入ってくる件はsimpleさんに記載していただいた通り
 「A1」セルに入力したら直りました。
 
 >A1セルに"項目"でも何でも入れれば、一行目からUsedRangeとなり、
 >不審な?動きはやむものと思います。
 
 「OPEN」「CLOSE」は、方針が変わって、やらないことになりました。
 えっと…もしまた方針が変わったら、質問させていただくかもです。(汗
 
 A列以外に設定する場合の変更方法も、
 下記で「A」としているところで変更できることも確認しました。(遅い?
 
 >lastRowA = sWS.Cells(sWS.Rows.Count, "A").End(xlUp).Row
 
 >If lastRowA >= 5 Then '5行目以上にデータがあれば転記
 >Intersect(sWS.Range("A5:A" & lastRowA).EntireRow, sWS.UsedRange).Copy _
    Destination:=dWS.Cells(dWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
 
 途中、色々わがままを言ってすみませんでした。
 親身な回答で、たくさん返信いただき、ありがとうございました。
 お陰様で完成させることができました。心から感謝しています。