セル値（シート名）を選択し空白の場合をご教示願います。

Question

ご教示願います。

下記のように、2つのブックがあり、1つのブックのセル値（A2）に入力しているブックを開き、2つ目のブックの
"シート1"、C列のセル値（C1）に入力しているシートに移動し（E3)をコピーし("集計表.xlsm")の（I2）に貼付をしていくのですが

シート1のC列の入力されているセルが追加したり削除したりします。
（C2）が削除になった場合、空白ができエラーになります。
C列で空白のセルの場合は、次に入力されている（C3）の作業にいく場合をご教示ください。
宜しくお願い致します。

Sub ブック()
'
' ブック Macro
'
Dim r As Range
For Each r In Range("A2")
Workbooks.Open ThisWorkbook.Path & "" & r.Value
Next

Sheets("シート1").Select

Dim str As String
**str = Worksheets("シート1").Range("C1")
**
Worksheets(str).Select

Range("e3").Select
Selection.Copy

Windows("集計表.xlsm").Activate
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 For Each r In Range("A2")
     Workbooks.Open ThisWorkbook.Path & "\" & r.Value
Next

Sheets("シート1").Select

str = Worksheets("シート1").Range("C2")

Worksheets(str).Select

Range("e3").Select
Selection.Copy

Windows("集計表.xlsm").Activate
Range("I3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 For Each r In Range("A2")
     Workbooks.Open ThisWorkbook.Path & "\" & r.Value
Next

Sheets("シート1").Select

str = Worksheets("シート1").Range("C3")

Worksheets(str).Select

Range("e3").Select
Selection.Copy

Windows("集計表.xlsm").Activate
Range("I3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub

Answer 1

Sub Sample()
    
    '2つのブックがあり、1つのブックのセル値（A2）に入力しているブックを開き、
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = ThisWorkbook
    Set wb2 = Workbooks.Open(wb1.Path & "\" & wb1.Worksheets(1).Range("A2").Value)
    
    '"シート1"
    Dim ws As Worksheet
    Set ws = wb2.Worksheets("シート1")

    '("集計表.xlsm")の（I2）
    Dim destCell As Range
    Set destCell = Workbooks("集計表.xlsm").Worksheets(1).Range("I2")
    
    Dim i, wsName As String
    For i = 1 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row

       '"シート1"、C列のセル値（C1）に入力しているシートに移動し
        wsName = ws.Cells(i, 3).Value
        If wsName <> "" Then
            '（E3)をコピーし("集計表.xlsm")の（I2）に貼付
            wb2.Worksheets(wsName).Range("E3").Copy destCell  
            Set destCell = destCell.Offset(1)
        End If
    Next

End Sub

---

＜追記＞
コメントの1.にあったような、対象のブックがA2、A3、、、と複数ある場合は、
以下のようにFor Nextをひとつ増やしてあげる感じでいけるのではないかと思います。
（試せていないのでおかしなところがあったら適宜直してください。）
なお、以下の例ではOffsetで出力セルをずらしていますが、
出力セルの行番号を保持する変数を用意して、都度カウントアップするほうが
わかりやすいかもしれません。

Sub Sample2()

    '2つのブックがあり、
    Dim wb1 As Workbook, wb2 As Workbook
    
    '1つのブックのセル値（A2,A3...）に入力しているブックを開き、
    Set wb1 = ThisWorkbook
    Dim r, wbName
    For r = 2 To wb1.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        wbName = wb1.Path & "\" & wb1.Worksheets(1).Cells(r, 1).Value
        Set wb2 = Workbooks.Open(wbName)
        
        '"シート1"
        Dim ws As Worksheet
        Set ws = wb2.Worksheets("シート1")
    
        'コピー先セル :  ("集計表.xlsm")の（I2,I3...）
        Dim destCell As Range
        Set destCell = Workbooks("集計表.xlsm").Worksheets(1).Cells(Rows.Count, 9).End(xlUp).Offset(1)
    
        Dim i, wsName As String
        For i = 1 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
    
           '"シート1"、C列のセル値（C1）に入力しているシートに移動し
            wsName = ws.Cells(i, 3).Value
            If wsName <> "" Then
                '（E3)をコピーし("集計表.xlsm")の（I2,I3...）に貼付
                destCell.Value = wb2.Worksheets(wsName).Range("E3").Value
                Set destCell = destCell.Offset(1)
            End If
        Next
    
    Next

End Sub

Comments

[chizuru0224]

jinoji様、ご教示いただきありがとうございます。
もう2点ほどご質問ですがご教示願います。
1、上記の方法でブック（"A2"）と追加でA3（ブック名）にも入力があった場合、（"I3")に追加して貼付ける方法
2，値で貼付け方法

宜しくお願い致します。

[jinoji]

取り急ぎ２の方だけ回答すると、
destCell.Value = wb2.Worksheets(wsName).Range("E3").Value
とするか、
wb2.Worksheets(wsName).Range("E3").Copy

1.については、A3までなのか、A4,A5・・・と続くことを想定しているかによるのかなと思います。
destCell.PasteSpecial Paste:=xlPasteValues
とするかのどちらかでいけると思います。

[chizuru0224]

jinoji様、早くのお返事ありがとうございます。
宜しければお時間があるとき１の内容をご教示いただきますと幸いです。
宜しくお願い致します。

[chizuru0224]

jinoji様、ご教示いただきありがとうございます。
また宜しくお願い致します。