VBA - Loop through list, copy/paste from 1st to 2nd sheet, copy/paste output from 2nd to 3rd sheet

[cde]

Summary Problem: I need to loop through a company list, copy a company from said list, one at a time, from first to second sheet, then copy a range output from the second sheet to a third sheet. I need that output that is pasted on the third sheet to be pasted moving down every third row (also paste values).

The loop is: Take Company 1 from list on sheet 1, paste into sheet 2, copy output from sheet 2 and paste values into sheet 3, row 6. I need the output that is being pasted in sheet 3 to paste every third row moving down. (e.g. paste first in row 6, then 9, then 12, etc....) I need the loop to run until it hits the first blank cell in the company list (sheet 1).

Details:
On a sheet called “List”, I have a list of companies that starts in B3 and can go to B25 up to B100. The range fluctuates. (e.g. B3:B25 one month, B3:B100 the next month.) (Once it hits that last company, I want the loop to stop.)
I have to copy that company from sheet “List” to sheet “Calc” and paste it in E8. I then need to copy a range in the "Calc" sheet (H384:R384) to a third sheet called “Model” starting in D6. I need that output to be pasted moving down every third row (value only).

Sheet: "List" (step 1)

	A	B	C
1
2
3		Company 1
4...98		Company 2...? (up to 96 could be blank)
99		Company 97 (could be blank
100		Company 98 (could be blank)

<tbody>
</tbody>

Sheet: "Calc" (step 2)

	A	...	E	...	H	...	R
1
...
8			Company 1 (pasted from sheet "List")
...
384			Output after pasting company ===>		28	85	79

<tbody>
</tbody>

Sheet: "Model" (step 3) Paste from "Calc" sheet above into every 3rd row

	A	...	C	D	...	N
1
...
6			Company 1	28	85	79
...
9...			Company 2	52	46	9
...306			Company 98	37	55	99

<tbody>
</tbody>

Here is my code I have so far:

Sub Run_Labor_Model()

Sheets("List").Select
Range("B3").Select
 
    Do Until ActiveCell = ""
        Range("B3").Copy
        Sheets("Calc").Select
        Range("E8").Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Range("H384:R384").Select
        Range("H384:R384").Copy
        Sheets("Labor Model").Select
        Range("C3").Select
        ActiveCell.Offset(3, 0).Select   'moving down every 3rd row to paste
        Selection.PasteSpecial Paste:=xlPasteValues
        
        Sheets("Lists").Select
        ActiveCell.Offset(1, 0).Select
 
    Loop
 
Sheets("Labor Model").Select
Range("A1").Select
 
End Sub

Hopefully I have adequately described the problem and given some helpful visuals. Thank you in advance for all your help.

 

[cde]

If it will help, I can try to upload a sample file, or possibly load one to onedrive.

 

[cde]

I got it! See the new code pasted below. The main change was in changing the code in line 13 to active cell, after designating the right starting point in line 2. I tweaked a couple other lines just to clean up the code. If you find this thread, the solution below is working for me. Hopefully the way I've described the problem above, and the code below will help you.

Sub Run_Model()

Sheets("Model").Select
Range("D6").Select   'set active cell on "Model" sheet for code line 13 below. it will start pasting data here.

Sheets("List").Select
Range("B3").Select     'set first cell of company list as active cell on "List" sheet.

    Do Until ActiveCell = ""
        ActiveCell.Copy     
        Sheets("Calc").Select
        Range("E8").Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Range("H384:R384").Select
        Range("H384:R384").Copy
        Sheets("Model").Select
        ActiveCell.Select   'Line 13:  see comment above. this cell set above to start pasting data here.
        Selection.PasteSpecial Paste:=xlPasteValues
        ActiveCell.Offset(3, 0).Select   'move down every 3rd row to paste new data
        
        Sheets("List").Select
        ActiveCell.Offset(1, 0).Select   'move down every row by one through company list.
 
    Loop
 
Sheets("Model").Select
Range("A1").Select
 
End Sub