I sort of think I might just maybe understand
I didn't know if you wanted the replacements to start over each time there's a new PART, so this version doesn't start over when PART changes
So 6, 13, 15 and 23 are replaced with the first, second, third, and then the first again since there are only 3 "DATA 30" replacements
It can be added
Capture.JPG
Option Explicit
Option Base 1
Dim rOriginal As Range, rReplace As Range
Sub Rotate()
Dim rArea As Range, rStart As Range
Dim vBlock() As Variant
Dim n As Long
Application.ScreenUpdating = False
'note space in sheet name
Set rOriginal = Worksheets("Sheet 1").Range("A:A").SpecialCells(xlCellTypeConstants)
Set rReplace = Worksheets("Sheet 2").Range("A:F").SpecialCells(xlCellTypeConstants)
For Each rArea In rReplace.Areas
'make even single cell areas into array starting at 1
If rArea.Cells.Count = 1 Then
vBlock = Array(rArea.Value)
ReDim Preserve vBlock(1 To 1)
Else
vBlock = Application.WorksheetFunction.Transpose(rArea.Value)
End If
Call ReplaceBlock(vBlock())
Next
Application.ScreenUpdating = True
End Sub
Private Sub ReplaceBlock(A() As Variant)
Dim C As Range
Dim n As Long
Dim firstAddress As String
Dim sPrefix As String
sPrefix = Left(A(1), 2)
n = 1
With rOriginal
Set C = .Find("DATA " & sPrefix, LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Address
Do
C.Value = A(n)
n = n + 1
If n > UBound(A) Then n = 1
Set C = .FindNext(C)
Loop While Not C Is Nothing
End If
End With
End Sub