VBAで複数シートの情報を一つのシートに集約

Question

実現したいこと

VBAで複数シートの情報を一つのシートに集約しようとしています。
この際、収集を除外するシートも設けています。

発生している問題・分からないこと

ただ収集が不規則であり、時には一番右端のシートのみ抽出します。
各シートのセルに結合箇所などはなく、
いろいろ調べてみましたがどうしても原因がわかりません。

該当のソースコード

On Error Resume Next
   Dim sh1, sh2 As Worksheet
   Dim dicT As Object
   Dim i, n,R1, R2 As Long
 
    Set sh1 = Worksheets("A")

For Each s In ThisWorkbook.Worksheets
    R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
    R2 = s.Cells(s.Rows.Count, "B").End(xlUp).Row

    n = R1 + 1
    For i = 2 To R2
 If s.Name <> "A" And s.Name <> "B" And s.Cells(i, "B") <> "" Then


        sh1.Cells(n, "B") = s.Cells(i, "A")

              n = n + 1
       End If
    Next 
    Next

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

For each ではなくシートをカウントするコードに書き換えましたが現象は変わりませんでした。

補足

特になし

Comments

[TakaiY]

> 収集が不規則であり
とはどいうい意味でしょう？ 具体的にどのようなことが置きているの説明いただけますか？
回答はここではなく、質問を編集して追記などするといいと思います。

[hajihaji]

ご返信ありがとうございます。
言葉足らずですみません。
やりたいことはシートAのA列にそのほか複数シートB列の情報をすべて抽出することです。
この際、シートAはもちろんシートBも収集対象から除外し、かつ収集先のB列の空欄も除外し、シートAのA列に玉突きで抽出したいのですが、この際、なぜか収集してくれるシートとそうでないシート、また抽出してくれる情報にムラがあるのです。具体的にはシートCは抽出してもシートDは抽出しない、B列の1行は抽出しても２行目は抽出しない。

[TakaiY]

ここはコメントを書くところなので、ここではなく、質問を編集して内容を変更したほうが多くの人に見てもらえますよ。(最初に書いたとおり)

[hajihaji]

ありがとうございます。
抽出先のシートに問題がある可能性があるので一度そこを確認しようと思います。

Answer 1

集計先はシートAのB列と解釈します。（A列は集計先でない）
R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
は、A列の最終行を取得しているので、どのシートを集計している場合でも、
常に同じ結果になります。
B列に集計するので、
R1 = sh1.Cells(sh1.Rows.Count, "B").End(xlUp).Row
と変えてください。
そうすると、
A列はなにも集計されないでB列に集計されるようになります。

余談ですが、
Dim sh1, sh2 As Worksheet
とすると、sh1はVariant型になります。
sh1をWorksheet型にしたいなら
Dim sh1 As Worksheet
Dim sh2 As Worksheet
とするか
Dim sh1 As Worksheet, sh2 As Worksheet
としてください。
Dim i, n, R1, R2 As Long　も同様です。
i,n,R1はVariant型になります。

Comments

[hajihaji]

ご返信ありがとうございます。
参考コードが不適切でしたので再度修正いたしました。
やりたいことはシートAのA列にそのほか複数シートB列の情報をすべて抽出することです。
この際、シートAはもちろんシートBも収集対象から除外し、かつ収集先のB列の空欄も除外し、シートAのA列に玉突きで抽出したいのですが、この際、なぜか収集してくれるシートとそうでないシート、また抽出してくれる情報にムラがあるのです。具体的にはシートCは抽出してもシートDは抽出しない、B列の1行は抽出しても２行目は抽出しない。
※型の件、ありがとうございます。初めてしりました。
On Error Resume Next
Dim sh1 As Worksheet, sh2 As Worksheet
Dim dicT As Object
Dim i As Long, n,R1, R2 As Long

Set sh1 = Worksheets("A")

For Each s In ThisWorkbook.Worksheets
R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
R2 = s.Cells(s.Rows.Count, "B").End(xlUp).Row
n = R1 + 1
For i = 2 To R2
If s.Name <> "A" And s.Name <> "B" And s.Cells(i, "B") <> "" Then
sh1.Cells(n, "A") = s.Cells(i, "B")
n = n + 1
End If
Next
Next

[tatsu99]

こちらでも提示されたコードで試験してみました。こちらで、確認した範囲では、正常に動作しています。
フィルターのかかったシートなどありませんでしょうか。フィルターがかかっていると、最終行を正しく取得できない場合があります。
型の件ですが
Dim i As Long, n,R1, R2 As Long
は
Dim i As Long, n As Long, R1 As Long, R2 As Long
としてください。
Dim i As Long, n,R1, R2 As Longとすると
n,R1がVariant型になります。

[hajihaji]

ご回答ありがとうございます。
やはり抽出対象のシートのほうに原因があるのかもしれないので再度確認をしてみます。

[tatsu99]

>具体的にはシートCは抽出してもシートDは抽出しない

抽出されないシートDとシートA、シートBの３つだけを残し、ほかのシートはすべて削除して、
試験すれば、原因がわかりやすくなるかと。
その場合は、シートDを一番左端に配置しておくと、
For Each s In ThisWorkbook.Worksheetsの個所で、シートDが最初にsに割り当てられるので、
step単位で実行を行えば、何が起こっているのかが、判るかと思います。

Answer 2

R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
n = R1 + 1
上記の２文をFor eachの上にもってきたところ解決しました。

On Error Resume Next
Dim sh1 As Worksheet, sh2 As Worksheet
Dim dicT As Object
Dim i As Long, n As Long ,R1 As Long, R2 As Long
Set sh1 = Worksheets("A")
R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
n = R1 + 1
For Each s In ThisWorkbook.Worksheets
R2 = s.Cells(s.Rows.Count, "B").End(xlUp).Row
For i = 2 To R2
If s.Name <> "A" And s.Name <> "B" And s.Cells(i, "B") <> "" Then
sh1.Cells(n, "A") = s.Cells(i, "B")
n = n + 1
End If
Next
Next