A simple Do-loop for copy and pasting and making a table

[driving is fun]

I wish to do a simple (I think!) Do-loop for the following: My simple program works as I want it to, but I think there is an easier way as I wish to repeat it 1000 times. Perhaps using some kind of loop? Do-Loop or otherwise. In short I want to:

1. copy the contents from A1
2. Paste them into B1
3. copy cell C1 (it has a simple formula that acts on B1)
4. copy the 'value' (only) from C1 into D1 (which will be a table of such values)

I wish to do this for A1 to A1000 and get a table of values D1, D2, ..., D1000 (perhaps as a square table). Cells B1 and C1 remain fixed.
At the end of the program I want t to return to cell A1.
My program is below:

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; white-space: inherit;">Sub PasteSpecial_Examples()

Range("A1").Copy Range("B1")
Range("C1").Copy
Range("D1").PasteSpecial Paste:=xlPasteValues

Range("A2").Copy Range("B1")
Range("C1").Copy
Range("D2").PasteSpecial Paste:=xlPasteValues

Range("A3").Copy Range("B1")
Range("C1").Copy
Range("D3").PasteSpecial Paste:=xlPasteValues

Range("A4").Copy Range("B1")
Range("C1").Copy
Range("D4").PasteSpecial Paste:=xlPasteValues


Application.CutCopyMode = False

End Sub
</code>

 

[Fluff]

Glad to help & thanks for the feedback

 

[driving is fun]

I used the answer by Fluff and it worked perfectly. However, I tried to change it a little and I keep getting errors. The main difference is that I am now also copying and pasting a row of values (not just from a single cell to anther single cell).
Here is the answer kindly provided by Fluff:

[COLOR=#333333]Sub CreateData()[/COLOR]
   Dim Cnt As Long
   Dim Rws As Long
   Dim Rw As Long
   Dim Clm As Long
   
   Clm = 3
   Rw = 1
   With Sheets("[COLOR=#0000ff]Sheet2[/COLOR]")
      For Cnt = 1 To .Range("A" & Rows.Count).End(xlUp).Row
         Clm = Clm + 1
         .Range("A" & Cnt).Copy .Range("B1")
         Sheets("[COLOR=#0000ff]Sheet1[/COLOR]").Cells(Rw, Clm).Value = .Range("C1").Value
         If Clm > [COLOR=#ff0000]12 [/COLOR]Then
            Rw = Rw + 1
            Clm = 3
         End If
      Next Cnt
   End With [COLOR=#333333]End Sub[/COLOR]

Here is my new intention:
1) copy row A1:H1 on sheet 1
2) paste the values only into A1:H1 on sheet 2[This will give a value (in one cell, say B1) also on sheet 2]
3) Copy B1 and paste the value only into (say) A1 on sheet 3 (as for the original answer, this will be the first answer in a table that may be 10x10 or even 100x100 or more)

For the next cycle:
1) this time, copy the next row down, i.e. A2:H2 on sheet 1
2) paste the values only into A1:H1 on sheet 2​(exactly as before)
3) Copy B1 (from sheet 2) and paste the value only into (say) A2 on sheet 3

Then:
1) this time, copy the third row down, i.e. A3:H3 on sheet 1
2) paste the values only into A1:H1 on sheet 2​(exactly as before)
3) Copy B1 and paste the value only into (say) A3 on sheet 3

And so on. Hence, for each step (1) we are copying a different row (each row consecutively, there will may be a 1000 or more)
But in step (2) we are pasting into the same row A1:H1 on sheet 2and copying the same B1 on sheet 2.
However, each resulting B1 from each cycle is pasted into different cell in a table on sheet 3.

 

[Fluff]

Untested, but try

Sub CreateData()
   Dim Cnt As Long
   Dim Rws As Long
   Dim Rw As Long
   Dim Clm As Long
   
   Clm = 0
   Rw = 1
   With Sheets("Sheet1")
      For Cnt = 1 To .Range("A" & Rows.Count).End(xlUp).Row
         Clm = Clm + 1
         .Range("A" & Cnt).Resize(, 9).Copy Sheets("Sheet2").Range("A1")
         Sheets("Sheet3").Cells(Rw, Clm).Value = Sheets("Sheet2").Range("B1").Value
         If Clm > 10 Then
            Rw = Rw + 1
            Clm = 0
         End If
      Next Cnt
   End With
End Sub

 

[driving is fun]

Untested, but try

Sub CreateData()
   Dim Cnt As Long
   Dim Rws As Long
   Dim Rw As Long
   Dim Clm As Long
   
   Clm = 0
   Rw = 1
   With Sheets("Sheet1")
      For Cnt = 1 To .Range("A" & Rows.Count).End(xlUp).Row
         Clm = Clm + 1
         .Range("A" & Cnt).Resize(, 9).Copy Sheets("Sheet2").Range("A1")
         Sheets("Sheet3").Cells(Rw, Clm).Value = Sheets("Sheet2").Range("B1").Value
         If Clm > 10 Then
            Rw = Rw + 1
            Clm = 0
         End If
      Next Cnt
   End With
End Sub

It worked beautifully, many thanks. Actually, copying into B1 was my mistake but that was simple enough to change. Just one thing, the results are in a table of 11 columns across (by however many rows). How would I change this (or fix it) to say a 10-column table or a 25-column table?

 

[Fluff]

Simply change this line

If Clm > [COLOR=#ff0000]10 [/COLOR]Then

to whatever number you want

 

[driving is fun]

Simply change this line

If Clm > [COLOR=#ff0000]10 [/COLOR]Then

to whatever number you want

Thank you for your help, once again. It works perfectly.

 

[Fluff]

You're welcome