集計シートA列のコードと一致する右に並んだシート名（コード）の3行目から10行目をコピーして貼り付け

集計シートA列のコードと一致する右に並んだシート名（コード）の3行目から10行目をコピーして貼り付けたい。
途中まで書いたコードで恐縮ですが修正点を教えていただけませんでしょうか？
①A列コードと一致するシート名を検索して貼り付けできない
②データ部分3行目から10行目の指定ができない
・・・・・・・・・・・・・・・・・・・・・・・・・・・
Sub TEST1()
'2つ目のシートから最終シートまでループ
For i = 2 To Sheets.Count
'データ部分のみを、集計シートにコピー
With Sheets(i).Range("A3").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1, 0).Copy Sheets("集計").Cells
(Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next
End Sub
よろしくお願い致します。

No.4 ベストアンサー 回答者： Qchan1962 回答日時： 2022/08/18 23:17

＃３です

同じ扱いにするようなコードもありますが
この場合は、シート名を比較しますので　For i = 2 To Sheets.Count　が必要になります

サンプルを実行しながら確認してみてください
Sub sample()
Dim keyCell As Range
Dim i As Integer
Set keyCell = Worksheets("集計").Range("A3")
Do While keyCell.Text <> ""
For i = 2 To Sheets.Count
With Worksheets(i)
If LCase(StrConv(.Name, vbNarrow)) = LCase(StrConv(keyCell.Text, vbNarrow)) Then
.Range("A3").Resize(8, .Range("A3").CurrentRegion.Columns.Count).Copy keyCell
Exit For
End If
End With
Next
Set keyCell = keyCell.End(xlDown)
Loop
End Sub

サンプルの場合、半角全角を半角として、更に大文字小文字を小文字として比較していますので　
例えばAの値が　Sheet2　で　シート名が　ShEet２　でも一致して　コピペされます。

この回答へのお礼

ありがとうございます。お示し頂いたコードの理解ができました。連日助けていただきありがとうございます♪

お礼日時：2022/08/19 10:12

No.3 回答者： Qchan1962 回答日時： 2022/08/18 22:40

>実行したところ反応がありませんでした？

数値ですね。。。keyCell.Value　をkeyCell.Text に変更してみてください
（２か所）

また、
＞一致するシート名　を前提にしていますが
シート名と集計シートA列コードの値はあっていますか？
　半角だったり全角だったりしませんか？
半角全角は同じではありません。また、半角スペースなどの混入も確かめてください
同じ扱いにするようなコードもありますが、取り敢えず同じではないので
書き加えていません

コードの説明
コード内ではシートが無い場合、On Error Resume Next　でエラーを飛ばして継続するようにしています（他のエラーでも）
なので何も無かったような結果になったと思います。

デバッグする場合、
一時的にOn Error Resume Next　をコメントとして実行するとエラーが
表示され止まります。
デバッグを選び、keyCell.Valueのにカーソルを重ねると値が確認できると思います。
エラーが出た場合、エラー№と止まったコードをお知らせください

No.2 回答者： Qchan1962 回答日時： 2022/08/18 18:23

こんばんは

＞修正点を教えていただけませんでしょうか？
A列コードの取得して比較する部分が必要かと
また範囲については、行数が決まっているのなら、定数で良いかと
カラム方向は不明なので・・・Columns.Countとかで取得する事が出来るかも
貼り付ける位置もシート名が書かれているA列該当セルで良さそうです

A列コードと一致するシート名がある場合で図のような場合、
ブック内のシートを調べる必要は乱暴に考えると無いと思います

やり方は色々考えられますが、こんな感じでどうでしょう
コードを書き替える時は少し苦労しそうかな・・

Sub test()
Dim keyCell As Range
Set keyCell = Worksheets("集計").Range("A3")
Do While keyCell.Value <> ""
On Error Resume Next
With Worksheets(keyCell.Value).Range("A3")
.Resize(8, .CurrentRegion.Columns.Count).Copy keyCell
End With
Set keyCell = keyCell.End(xlDown)
Loop
End Sub

少し乱暴かも知れませんが、あくまで参考図とご質問に沿った場合なので
参考程度で

この回答へのお礼

ありがとうございます。ご指南頂いたコードで実行したところ反応がありませんでした？

お礼日時：2022/08/18 21:19

No.1 回答者： fujillin 回答日時： 2022/08/18 17:56

こんにちは

ご質問の文章の内容と、ご提示のコードに関連性が見られないので、何をなさりたいのかよくわかりませんけれど・・
（図もあまりよく見えないので、正確には理解できませんけれど・・）

文章の方を正とするなら・・
1）集計シートのA列を8行おき（←固定で良いのか不明）に読んで
2）その値と同じシートがあるかチェック
3）シートがあれば3～10行を（集計シートの）同じ行から8行にコピペ
　（シートが無い場合については、記載が無いのでどうするのか不明）
という手順にする必要があります。

一方でご提示のコードは
・シートをループしている
・最終行までを取得している
・CurrentRegionとしているが、B:Dというのは列固定ではないのか？
・貼り付け先も「集計シート」最下行となっている
　（多分、2シート目からオーバーフローしてエラーになりそう）
などなど、ご質問文とはまったく異なる内容になっているように思われます。


考え方は全く変わりますけれど・・
もしも、「集計シート」が文字通りの集計用で、各個別シートの内容を反映すれば良いだけのものであるのなら、集計シートに関数で参照式を設定しておけば済むことのようにも思われます。
そうすることで、マクロを実行せずとも、各シートに入力した内容は「集計シート」に即時に反映されるようになると思いますけれど・・

ただし、「集計シート」のフォーマットが必ずA列の8行おきにシート名が記載されているなどの条件が固定である必要はあります。
また、シート名をセルから参照する形式になるので、INDIRECT関数の利用になってしまうという欠点はありますが。

この回答へのお礼

ありがとうございます。
説明が不十分でしたがご推測123のように動くことができればと考えています。

お礼日時：2022/08/18 21:17