Copying a specific range to all sheets - excel

Question

I wrote this code, but I'm having trouble getting it to work properly.Instead of seeing C2:D5 as a range of ten items, I'd like to see C2 and cell D2 as a single item, and so on. Instead of ten items, the list will essentially consist of five. This is then copied to the appropriate cells D3:E3, as shown below. Is that even possible with vba?
Dim wb As Workbook
Set wb = ThisWorkbook
Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")
Dim r As Range
Set r = startsheet.Range("C2:D5") '
Dim sh As Worksheet
For Each sh In Worksheets
For i = 1 To r.Count
If Not i + 1 > Worksheets.Count Then Worksheets(i + 1).Range("D3:E3").Value = r.Item(i,1).Value
Next i
Next sh
End Sub ```

Answer 1

The problem in your code was that you were using 2 loops when you only needed one. The loop for the sheets was unnecesary because you were already looping through sheets with the code "Worksheets(i + 1).Range("D3").Value"
Sub test()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim i As Long
Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")
Dim r As Range
Set r = startsheet.Range("C2:D5")
Dim sh As Worksheet
For i = 1 To r.Rows.Count
If Not i + 1 > wb.Worksheets.Count Then
Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
Else
End If
Next i
End Sub

Answer 2

Yes, you can easily touch up the code to add sheets if you add more items to column C in startsheet. It'd be like this:
Sub TEST()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim i As Long, LastRow As Long
Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")
LastRow = startsheet.Range("C2:C" & Rows.Count).End(xlDown).Row
Dim r As Range
startsheet.Activate
Set r = startsheet.Range(Cells(2, 3), Cells(LastRow, 3))
Dim sh As Worksheet
For i = 1 To r.Rows.Count
If i + 1 > wb.Worksheets.Count Then
Set sh = wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
Else
Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
End If
Next i
End Sub

Answer 3

I will use copy method again, however I will assume the copy sheet is sheet1 and you already created sheet 2 -5 for the function, please try and see and modify for if statement in case you have other issue:
Sub test2()
Dim wb As Workbook
Dim i As Long
Set wb = ThisWorkbook
Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")
For i = 2 To ThisWorkbook.Worksheets.Count
startsheet.Range("C" & i, "D" & i).Copy Worksheets(i).Range("D3")
Next
End Sub

Answer 4

Copy Each Row to Each Next Worksheet
If you opt for using .worksheets(1) then remove the swsName constant.
Play with the values of the remaining three constants.
Sub CopyRowsForNext()
Const swsName As String = "start"
Const srgAddress As String = "C2:D5"
Const dFirst As String = "D3" ' First Destination Cell
Const wsFirst As Long = 2 ' First Destination Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCount As Long: wsCount = wb.Worksheets.Count
If wsCount = 0 Then Exit Sub
Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
' Maybe this would be more appropriate (forgetting about "start"):
'Dim sws As Worksheet: Set sws = wb.Worksheets(1)
Dim srg As Range: Set srg = sws.Range(srgAddress)
Dim srCount As Long: srCount = srg.Rows.Count
Dim scCount As Long: scCount = srg.Columns.Count
Dim cIndex As Long
Dim r As Long
For r = 1 To srCount
cIndex = r + wsFirst - 1
If cIndex <= wsCount Then
wb.Worksheets(cIndex) _
.Range(dFirst).Resize(, scCount).Value = srg.Rows(r).Value
End If
Next r
End Sub
Sub CopyRowsForEachNext()
Const swsName As String = "start"
Const srgAddress As String = "C2:D5"
Const dFirst As String = "D3" ' First Destination Cell
Const wsFirst As Long = 2 ' First Destination Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCount As Long: wsCount = wb.Worksheets.Count
If wsCount = 0 Then Exit Sub
Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
' Maybe this would be more appropriate (forgetting about "start"):
'Dim sws As Worksheet: Set sws = wb.Worksheets(1)
Dim srg As Range: Set srg = sws.Range(srgAddress)
Dim srCount As Long: srCount = srg.Rows.Count
Dim scCount As Long: scCount = srg.Columns.Count
Dim srrg As Range
Dim cIndex As Long
Dim n As Long
For Each srrg In srg.Rows
n = n + 1
cIndex = n + wsFirst - 1
If cIndex <= wsCount Then
wb.Worksheets(cIndex) _
.Range(dFirst).Resize(, scCount).Value = srrg.Value
End If
Next srrg
End Sub