VBA自動入力処理ができません。。。

Question

実現したいこと
添付写真1枚目のシートの列情報を改行して一列ずつ追加済みのシートの指定箇所に転記したい。

VBAで自動化を図って100件の自動入力を行いたいのです。現在データ量に対するシートの作成はできてます。
ただデータのコピーペーストがうまくいかず
下のプログラムだと一番左のシートの該当箇所に入力されるのみで一つずつシートが切り替わって入力繰り返しという動きになりません。

1、2、3、4、5、、、のGIDを
アカウントとIDの指定のセルに1
アカウントとID（2）の指定のセルに2と
転記するにはあと何が足りないのでしょうかご教授いただけないでしょうか？
データ総量変更可能性があるためデータ量指定したfor文では作りたくないのですが可能でしょうか？

申し訳ございませんがどなたかご教授いただけますと幸いです。

該当のソースコード

Sub ボタン4 Click()
Dim 行数 As Long
変数「行数」を作成
Dim 最終行 As Long
変数「最終行」を作成
Dim sheet no As Long
"コピー先シート番号
Dim sheet name As String
コピー先シート名
Dim sh1 As Worksheet
"Sheeti
Application.ScreenUpdating = False
・画面を止める
Set shl = Worksheets ("sheet!")
最終行 = Cel Is (Rows.Count,
sheet no = I
“A").End(x1Up) ROw最終行取得
For 行数 = 1 To 最終行
"最終行まで繰り返し
sheet name =
アカウントとID
& sheet no
Horksheets(アカウントと10”).Cells(27,
• 4). Value = shl.Cells(1]#t, 1). Value
sheet no = sheet no + 1
Next 行数
Application.ScreenUpdating = True #7.$
wseBox
”転記終了しました’’

End Sub

Comments

[pig_vba]

現状恐らく環境違いによる文字化け？当の要因でコードが正しい状態になっていない(変数sheet noのように間にスペースがあり不成立、コメントアウトがないので全部コード扱い、shl.Cells(1]#t, 1)等謎の文字が追加されている)ため、回答者側で検証が難しい状態になっており回答が難しくなっています。コードを修正の後、コード部分をマークダウンのコード挿入```
で括って更新していただけますでしょうか。

Horksheets(アカウントと10”).Cells(27,
• 4). Value = shl.Cells(1]#t, 1). Value
↓こう？
Worksheets("アカウントとID").Cells(27,4). Value = shl.Cells(1, 1). Value

この部分が先頭シートにすべて転記されてしまっている原因だと思います。
仮に直すなら
sheet_name ="アカウントとID（" & sheet no & "）"
Worksheets(sheet_name).Cells(27,4). Value = shl.Cells(1, 1). Value

こうでしょうか？

Answer 1

こういうことですかね？

Sub ボタン4_Click()

Dim 行数 As Long '変数「行数」を作成
Dim 最終行 As Long '変数「最終行」を作成
Dim sheet_no As Long 'コピー先シート番号
Dim sheet_name As String 'コピー先シート名
Dim sh1 As Worksheet 'Sheet1

Set sh1 = Worksheets("sheet1")

最終行 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
sheet_no = 1

For 行数 = 2 To 最終行 '最終行まで繰り返し
    sheet_name = "アカウントとID (" & sheet_no & ")"
    Worksheets(sheet_name).Cells(27, 4).Value = sh1.Cells(行数, 1).Value
    sheet_no = sheet_no + 1
Next 行数

MsgBox "転記終了しました"

End Sub

画像があまり読み取れずわかりませんでしたが、エラーで「インデックスが有効範囲にありません｣と出ていませんでしたか？
シート名がうまく取得できていなかったのではないでしょうか。

Answer 2

こんな感じでどうでしょうか。

Sub ボタン4_Click()
Dim 行数 As Long
'変数「行数」を作成
Dim 最終行 As Long
'変数「最終行」を作成
Dim sheet_no As Long
'コピー先シート番号
Dim sheet_name As String
'コピー先シート名
Dim sh1 As Worksheet
'Sheet1
Application.ScreenUpdating = False
'画面を止める
Set sh1 = Worksheets("sheet1")
最終行 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
sheet_no = 1
For 行数 = 1 To 最終行
'最終行まで繰り返し
sheet_name = "アカウントとID (" & sheet_no & ")"
Worksheets(sheet_name).Cells(27, 4).Value = sh1.Cells(行数, 1).Value
sheet_no = sheet_no + 1
Next 行数
Application.ScreenUpdating = True
MsgBox "転記終了しました"

End Sub

Answer 3

ソースコードはAIによる自動判別してテキスト化したものでしょうか？
全く意味の分からない物になっています。
ゆえにどうしたいのかもはっきり分かりません。
修正をお願いします。