処理の繰り返しについて教えてください

質問

A列1行目の値をD列1行目にコピーし、E列でD列の文字列の右から3文字を返す。
そしてD列の下端までコピーの繰り返しD列の下端より1行下がりA列に戻る。
A列※行目の値をD列※行目にコピー・・・・。といった作業をD列の一番下のセル
まで繰り返したいです。

さらにこの作業をブック内の左から数えて2個を除いた10個程度あるシートの
すべてで反映させたいです。

下の感じで作ってみたのですが、繰り返し処理がイマイチよくわかりません。
ご指導のほどよろしくお願いします。

Cells(1, 1).Copy 'A列1行目の値をD列1行目にコピー(1)
Cells(1, 4).PasteSpecial Paste:=xlValues
ActiveCell.Offset(0, 1).Select 'E列でD列の文字列の右から3文字を返す(2)
ActiveCell.FormulaR1C1 = "=right(RC[-1],3)"
j = Cells(1, 4).End(xlDown).Row 'D列の下端を指定して
For i = 1 To j
Cells(1, 5).Copy 'D列の下端までコピーの繰り返し(3)
Cells(i, 5).PasteSpecial Paste:=xlValues
Next i
ActiveCell.Offset(1, -4).Select 'D列の下端より1行下がりA列に戻る(4)
Cells(※, 1).Copy 'A列※行目の値をD列※行目にコピー(6)
Cells(※, 4).PasteSpecial Paste:=xlValues

　　　　　　A列　　　　　　　　 　D列　　　　　　 　 E列
1 　****●▽■(1)　　　　****●▽■(2)　　　 　　●▽■(3)
2　　　 　　　　　　　　　　　　　 ****　　　　　　　　　　 ●▽■ 3　 　
3　　　　　　　　　　　　　　　　 　　 ***** 　　 　　●▽■
4　　　　 　　　　　　　　　　　 ***** 　　　　　 　　　　●▽■
6 　　****■▽■(5)　　　　****■▽■(6)

回答No.1

zap35 · ベストアンサー

こんなマクロではどうですか？
マクロは標準モジュールに貼り付けてください

Sub Macro2()
Dim idx As Long
Dim sh As Integer
　For sh = 1 To Worksheets.Count
　　Worksheets(sh).Activate
　　If sh > 2 Then
　　　With ActiveSheet
　　　　For idx = 1 To .Range("A65536").End(xlUp).Row
　　　　　If .Cells(idx, "A") <> "" Then
　　　　　　.Cells(idx, "D").Value = .Cells(idx, "A")
　　　　　　.Cells(idx, "E").Value = Right(.Cells(idx, "D"), 3)
　　　　　Else
　　　　　　.Cells(idx, "E").Value = .Cells(idx, "E").Offset(-1, 0)
　　　　　End If
　　　　Next idx
　　　End With
　　End If
　Next sh
End Sub

お礼

ありがとうございました。
おかげさまで成功しました。