Excel (VBA)

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

 
(Windows 7全般 : Excel 2010)
複数ブックを抽出しまとめる方法
投稿日時: 19/01/07 09:26:10
投稿者: taigernotora

VBA初心者です。複数ブックを開き抽出できるマクロを作成しているのですが、最後に先頭行の貼り付ける方法について悩んでいます。
 
今のところ考えているのが、
@ 先頭行だけ変数に代入して最後に貼り付け
A Do while文以外の構文の作成
 
どなたかご教授よろしくお願いします。
 
―――――――――――――――――――――――――――――――――――――――――――――――――
以下コード↓
 
 
Sub dm()
 
    ConfigName$ = ThisWorkbook.Name
    Dim Second As Worksheet
    Dim Result As Worksheet
    Dim Origin As Worksheet
    Dim DataStartLine As Long, DataEndRow As Long
    Dim Cnt As Long, DataEndLine As Long, PastePos As Long, PasteEndPos As Long
    Dim Row As Range
     
    Set Second = Workbooks(ConfigName$).Worksheets("Second")
    Set Result = Workbooks(ConfigName$).Worksheets("Result")
     
    Cnt = 1
     
    TargetPath$ = Second.Cells(Cnt, 5).Value
    DataStartLine = Second.Cells(1, 2).Value
    DataEndRow = Second.Cells(2, 2).Value
    PastePos = 1
     
    Do While TargetPath$ <> ""
        DataEndLine = DataStartLine
         
        Workbooks.Open Filename:=TargetPath$, ReadOnly:=True
         
        OriginName$ = ActiveWorkbook.Name
        Set Origin = Workbooks(OriginName$).Worksheets(ActiveSheet.Name)
        Set Row = Workbooks(OriginName$).Worksheets(ActiveSheet.Name).Range(Cells(1, 1), Cells(1, DataEndRow))
         
        DataLine = Origin.Cells(DataEndLine + 1, 1)
         
        Do While DataLine <> ""
            DataEndLine = DataEndLine + 1
            DataLine = Origin.Cells(DataEndLine + 1, 1)
        Loop
         
        PasteEndPos = PastePos + (DataEndLine - (DataStartLine - 1)) - 1
        Result.Activate
        Result.Cells(PastePos, 1).Select
        Range(Result.Cells(PastePos, 1), Result.Cells(PasteEndPos, DataEndRow)).Value
    = Range(Origin.Cells(DataStartLine, 1), Origin.Cells(DataEndLine, DataEndRow)).Value
         
        Workbooks(OriginName$).Close
         
        PastePos = PasteEndPos + 1
 
        Cnt = Cnt + 1
         
        TargetPath$ = Second.Cells(Cnt, 5).Value
    Loop
     
End Sub

回答
投稿日時: 19/01/07 10:10:58
投稿者: WinArrow
投稿者のウェブサイトに移動

注意事項
(1)コードの見易さの問題
 
変数:ROw は、変えた方あよい
Rowは、ExcelVBAのRowプロパティ名でもあり、セルオブジェクトを読み間違える可能性があります。
 
(2)次のコードは、簡略できます
> Set Row = Workbooks(OriginName$).Worksheets(ActiveSheet.Name).Range(Cells(1, 1), Cells(1, DataEndRow))

    With Origin
        Set Row = .Range(.Cells(1, 1), .Cells(1, DataEndRow))
    End With
 
質問
>先頭行
がどこかわかりません。
どこへ貼り付けるのかがわかりません。

投稿日時: 19/01/07 13:27:51
投稿者: taigernotora

コメント頂きありがとうございます。
 
【注意事項】
ご指摘ありがとうございます。
全体修正の際に変更させて頂きます。
 
※追記
Dim Row As Range
Set Row = Workbooks(OriginName$).Worksheets(ActiveSheet.Name).Range(Cells(1, 1), Cells(1, DataEndRow))
の『@先頭行だけ変数に代入して最後に貼り付け 』でできないかと思い付け足してしまった二行は途中作成の不要なコードでした。簡略化の方法ご教授頂きありがとうございます。
 
【質問】
@>先頭行がどこかわかりません。
パスで読み込んだ複数のワークブックを"Result"に抽出するマクロになっております。
そのため、先頭の数行が数値データでない不要なデータのため、下記で不要なデータを削除して連続データとして貼り付けております。
>DataStartLine = Second.Cells(1, 2).Value
今回の場合は、1行目が先頭行の項目行となりますが可能であれば項目行を可変にできればと考えております。説明が不足しており申し訳ありません。
 
ex)例ですがexcelシートは下記のようになっております。
 
時間 客数 売り上げ ← 先頭行(加えたい行)
1:00 1   1000  ← DataStartLine
2:00 10  10000
3:00 3   5000
4:00 5   8000
 
Aどこへ貼り付けるのかがわかりません。
貼り付け先は、"Result"のシートになります。
 
>Dim Result As Worksheet
>〜〜〜〜〜
>Set Result = Workbooks(ConfigName$).Worksheets("Result")
>〜〜〜〜〜
>Result.Activate
>Result.Cells(PastePos, 1).Select
 

回答
投稿日時: 19/01/07 14:08:14
投稿者: WinArrow
投稿者のウェブサイトに移動

基本的なことを質問します。
 
@複写元ブックは、複数あるのですね?
A各々のブックにはシートは1つだけですか?
B各々のシートのデザイン(レイアウト等)はすべて同一ですか?
 →各々のが異なれば、当マクロブックに「DataStartLine」を持つ意味がない
 項目行が各々で異なるということは、項目行を意味するデータを探すことになります。
 それはなんですか?
  例えば、A列の「時間」という値のセルを項目行と判断する・・・とか
 
C複写先ブックは、当マクロブックですか?
DDataEndRowという名前の変数:
 Rowというから、行の終わりかと思ったら、最右列なんですね?
 紛らわしい名前は、使わないことです。
 DataEndColumn と変更したら・・・
ERESOLTシートいは、1行目から貼り付けていますが、
 後から貼り付けるということは、1行挿入するということですか?
 私だったら、最初のブック読込時に複写しますが・・・
 
Fこのプロシジャ内に定義されていない変数は、どこで定義していますか?
 

回答
投稿日時: 19/01/07 15:40:22
投稿者: WinArrow
投稿者のウェブサイトに移動

 
間違いではないが、回りくどく、わかりにくいコードが多々見受けられるので
参考コードを提示します。
  
Option Explicit
   
   
 Sub dm()
 Dim Targetpath$
 Dim Second As Worksheet
 Dim Result As Worksheet
 Dim DataStartLine As Long, DataEndColumn As Long
 Dim Cnt As Long
 Dim ResultCell As Range
    
     With ThisWorkbook
         Set Second = .Worksheets("Second")
         Set Result = .Worksheets("Result")
     End With
     DataStartLine = Second.Cells(1, 2).Value
     DataEndColumn = Second.Cells(2, 2).Value
        
     With Second
         For Cnt = 1 To .Range("E" & .Rows.Count).End(xlUp).Row
             Targetpath$ = .Cells(Cnt, "E").Value
             GoSub HUKUSYA
         Next
     End With
     Exit Sub
   
 HUKUSYA:
     With Workbooks.Open(Filename:=Targetpath$)
         With .Sheets(1)
             DataStartLine = WorksheetFunction.Match(.Columns("A"), "時間", 0) + 1
             GoSub GETPASTEROW
             If ResultCell.Value = "" Then
                 ResultCell.Resize(, DataEndColumn).Value = _
                     .Cells(DataStartLine - 1, "A").Resize(, DataEndColumn).Value
             End If
             ResultCell.Offset(1).Resize(DataEndColumn).Value = _
                 .Cells(DataStartLine, "A").Resize(, DataEndColumn).Value
         End With
         .Close False
     End With
     Return
       
 GETPASTEROW:
     'Resultシートのデータの最終行を取得
    'データ無は、1行目が取得される
    With Result
         Set ResultCell = .Range("A" & .Rows.Count).End(xlUp)
     End With
     Return
               
 End Sub
   
 ※未実行なので、試してみて
 

回答
投稿日時: 19/01/07 16:56:53
投稿者: Suzu

判りづらかったので、改変。 要らなそうな変数、及び処理 削除
 

引用:
Do While DataLine <> ""
            DataEndLine = DataEndLine + 1
            DataLine = Origin.Cells(DataEndLine + 1, 1)
        Loop

これを見ると、DataEndLine が、1処理に、2 カウントアップしている。
ので、最終行取得後更に 2 カウントアップ。
 
 
Option Explicit

Sub dm2()
Dim Second As Worksheet   'コード記載ワークブック シート Second
Dim Result As Worksheet   'コード記載ワークブック シート Result
Dim Origin As Worksheet   'ワークブック(TargetPath) アクティブシート

Dim TargetPath As String  'シートSecond E列 ワークブックフルパス

Dim DataStartLine As Long, DataEndClm As Long
Dim Cnt As Long, DataEndLine As Long, PastePos As Long, PasteEndPos As Long

With ThisWorkbook
  Set Second = .Worksheets("Second")
  Set Result = .Worksheets("Result")
End With

Cnt = 1

TargetPath$ = Second.Cells(Cnt, 5).Value
DataStartLine = Second.Cells(1, 2).Value
DataEndClm = Second.Cells(2, 2).Value

'貼りつけ行指定変数
PastePos = 1

Do While TargetPath$ <> ""
  DataEndLine = DataStartLine

  Set Origin = Workbooks.Open(Filename:=TargetPath$, ReadOnly:=True).ActiveSheet

  'シートOrigin A1アクティブ Ctl+↓ にて取得できる行数 + 2
  DataEndLine = Origin.Cells(DataEndLine + 1, 1).End(xlDown).Row + 2

  PasteEndPos = PastePos + (DataEndLine - (DataStartLine - 1)) - 1
'  Result.Cells(PastePos, 1).Select

  Origin.Range(Origin.Cells(DataStartLine, 1), Origin.Cells(DataEndLine, DataEndClm)).Copy
  Result.Cells(PastePos, 1).PasteSpecial Paste:=xlPasteValues

  Origin.Parent.Close SaveChanges:=False
  PastePos = PasteEndPos + 1

  Cnt = Cnt + 1

  TargetPath$ = Second.Cells(Cnt, 5).Value
Loop

End Sub

 
あとは、項目行をコピペする処理なのでしょうから
それは、
引用:
'貼りつけ行指定変数
PastePos = 1
貼りつけ開始行を、1→3に変え、実際の項目貼りつけ処理を追加しましょう。

投稿日時: 19/01/08 09:44:37
投稿者: taigernotora

>Winarrow様
  
コメント頂きありがとうございます。
   
@複写元ブックは、複数あるのですね?
はい異なる情報を持つブックが複数あります。
>TargetPath$ = Second.Cells(Cnt, 5).Value
に示したように、5列目にあるパスを
>Do While TargetPath$ <> ""
でパスがなくなるまで処理をしたいという意図でございます。
  
A各々のブックにはシートは1つだけですか?
シートは複数ありますが、開いた時に出てくるシートを処理するというコードです。
改良しなければとは考えておりました…
  
B各々のシートのデザイン(レイアウト等)はすべて同一ですか?
レイアウトは同一になります。同一形式で数値データのみ異なるものです。 
  
C複写先ブックは、当マクロブックですか?
はいそうなります。
  
DDataEndRowという名前の変数:
 Rowというから、行の終わりかと思ったら、最右列なんですね?
 紛らわしい名前は、使わないことです。
 DataEndColumn と変更したら・・・

失礼しました…。今後誤解釈を防ぐために改良します。
   
ERESOLTシートいは、1行目から貼り付けていますが、
 後から貼り付けるということは、1行挿入するということですか?
 私だったら、最初のブック読込時に複写しますが・・・

本当は、そちらの方が良いですよね…。繰り返しをする際に簡単かと思い、最後に一行加えようかなと考えていました。最初のブック読み込み時に複写するコードも合わせて考えたいと思います。
   
Fこのプロシジャ内に定義されていない変数は、どこで定義していますか?
確認抜けがあり失礼いたしました。具体的な変数を教えて頂けると幸いです。

投稿日時: 19/01/08 10:00:47
投稿者: taigernotora

コードありがとうございます。
初心者なもので時間がかかりますが頑張って落とし込んでみたいと思います。
 
↓下記コードでエラーが出てしまいました。

WinArrow さんの引用:

             DataStartLine = WorksheetFunction.Match(.Columns("A"), "時間", 0) + 1
             If ResultCell.Value = "" Then
                 ResultCell.Resize(, DataEndColumn).Value = _
                     .Cells(DataStartLine - 1, "A").Resize(, DataEndColumn).Value

回答
投稿日時: 19/01/08 10:38:48
投稿者: WinArrow
投稿者のウェブサイトに移動

すみません、コードの記述ミスです
誤:DataStartLine = WorksheetFunction.Match(.Columns("A"), "時間", 0) + 1

正:DataStartLine = WorksheetFunction.Match("時間", .Columns("A"), 0) + 1

投稿日時: 19/01/08 13:29:32
投稿者: taigernotora

>Winarrow様
   
コード修正ありがとうございます。
大変参考になりましたが、以下の二つの問題が出てしまいました。
 
@項目行の貼り付けはできましたが、時間データ以外の数値データ貼り付けができませんでした。
A時間データの貼り付けはできたのですが、時刻が全て同一となってしまいました。
 
一度コード確認させて頂きます。ありがとうございます。

回答
投稿日時: 19/01/08 14:00:19
投稿者: WinArrow
投稿者のウェブサイトに移動

taigernotora さんの引用:

A各々のブックにはシートは1つだけですか?
シートは複数ありますが、開いた時に出てくるシートを処理するというコードです。
改良しなければとは考えておりました…

 
複写元ブックは、手操作で保存することがあるとしたら、
ActiveSheetは、プログラムで扱うシートという保証はないですね。
シート名が同一でしたら、シート名を指定すべきです。
taigernotora さんの引用:

Fこのプロシジャ内に定義されていない変数は、どこで定義していますか?
確認抜けがあり失礼いたしました。具体的な変数を教えて頂けると幸いです。

 
各モジュールの先頭に
Option Explicit
を記述してみてください。
定義されていない変数を教えてくれます。
なお、VBEのメニューの「ツール→「オプション」で表示されるダイアログの中の
[自動構文チェック]にチェックを折れると
モジュールを生成したときに
Option Explicit
が自動創友されます。

回答
投稿日時: 19/01/08 14:06:29
投稿者: WinArrow
投稿者のウェブサイトに移動

文章訂正
>が自動創友されます。

が自動挿入されます。
 
 
>@項目行の貼り付けはできましたが、時間データ以外の数値データ貼り付けができませんでした。
>A時間データの貼り付けはできたのですが、時刻が全て同一となってしまいました。
この原因を探るために
 
→ DataEndColumn = Second.Cells(2, 2).Value
 
この行にブレークポイントを設定し
DataEndColumnの値を確認してみてください。
 

回答
投稿日時: 19/01/08 14:12:45
投稿者: WinArrow
投稿者のウェブサイトに移動

再度のコード修正
 
> ResultCell.Offset(1).Resize(DataEndColumn).Value = _
> .Cells(DataStartLine, "A").Resize(, DataEndColumn).Value

             DataEndLine = .Cells(.Rows.Count, "A").End(xlUp).Row
             ResultCell.Offset(1).Resize(DataEndLine-1, DataEndColumn).Value = _
                  .Cells(DataStartLine, "A").Resize(DataEndLine-1, DataEndColumn).Value

投稿日時: 19/01/08 18:47:06
投稿者: taigernotora

>Suzu様
 
コメント遅くなり申し訳ありません。
.End(xlDown).Row
のコードを知らなかったため大変勉強になりました。
項目行の追加につきましては、変数を指定してif文で場合分けして貼り付けることで対処できました。
 
コード整理含めご指摘ありがとうございました。今後ともよろしくお願い致します。

投稿日時: 19/01/08 18:52:23
投稿者: taigernotora

>WinArrow様
 
複写元ブックは、手操作で保存することがあるとしたら、
ActiveSheetは、プログラムで扱うシートという保証はないですね。
シート名が同一でしたら、シート名を指定すべきです。

 
シート名の指定修正を加えました。
懸念事項含めご説明ありがとうございます。
 
Option Explicit を記述してみてください。 定義されていない変数を教えてくれます。
 
設定方法までご説明頂きありがとうございます。
加えて変数を特定することができました。
ありがとうございました。

投稿日時: 19/01/08 18:54:53
投稿者: taigernotora

>WinArrow様
 
コード修正の連絡と要因解析方法の手順ご説明ありがとうございます。
この後、確認してみたいと思います。

回答
投稿日時: 19/01/09 18:10:03
投稿者: WinArrow
投稿者のウェブサイトに移動

再々のコード修正です。
 
前レスのコードで、できないということはないと思いますが、
データの範囲外も複写されてしまうので、
データの範囲だけに限定するという論理にコードを修正します。
 
> DataEndLine = .Cells(.Rows.Count, "A").End(xlUp).Row
> ResultCell.Offset(1).Resize(DataEndLine-1, DataEndColumn).Value = _
> .Cells(DataStartLine, "A").Resize(DataEndLine-1, DataEndColumn).Value

             DataEndLine = .Cells(.Rows.Count, "A").End(xlUp).Row - DataStartLine + 1
              ResultCell.Offset(1).Resize(DataEndLine, DataEndColumn).Value = _
                   .Cells(DataStartLine, "A").Resize(DataEndLine, DataEndColumn).Value

投稿日時: 19/01/10 14:28:41
投稿者: taigernotora

>Winarrow様
   
コメントが遅くなってしまい申し訳ありません。
項目行も加わった形でマクロ処理完了できました。
 
詳細まで細かく教えて頂きありがとうございました。特に、サブルーチンへの分岐方法はまだコードを作ったことがなかったため後学においても大変勉強になりました。
 
引き続きどうぞよろしくお願い致します。