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>

 

[My Aswer Is This]

Try this:

Sub Test()
'Modified 2-9-18 1:35 AM EST
Application.ScreenUpdating = False
Dim i As Long
    For i = 1 To 1000
        Cells(i, 1).Copy Range("B1")
        Cells(i, "D").Value = Cells(i, "C").Value
    Next
Application.ScreenUpdating = True
End Sub

 

[vcoolio]

..........or perhaps:-

Sub DoThings()

Dim lr As Long
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row

With Sheet1
        .Range("B2:B" & lr) = .Range("A2:A" & lr).Value
        .Range("D2:D" & lr) = .Range("C2:C" & lr).Value
End With

End Sub

Cheerio,
vcoolio

 

[My Aswer Is This]

Your image shows we are always copying to "B1"

 

[driving is fun]

Thank you but I am afraid it is not quite working.
I copied your code but changed 1000 to 100 just for testing.

I get only one answer in D1, not a table of 100 answers in (say) D1 to D100 (or better, as a square table)

 

[driving is fun]

Thank you. I tried this but it seems to miss out A1 and B1, so I edited it to this:

Sub DoThings()

Dim lr As Long
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row

With Sheet1
.Range("B1:B" & lr) = .Range("A1:A" & lr).Value
.Range("D1:D" & lr) = .Range("C1:C" & lr).Value
End With

End Sub

To test this I put values 1 to 10 in cells A1 to A10.
On running the program I get the same values copied into cells B1 to B10, and only one value in D1.

Maybe I should explain differently.
Let's say I gave values 1-10 in cells A1-A10.
I want to copy the 'value' in A1 (in this case the number 1) into cell B1. Then, in C1 the value '11' will appear as it has the formula '=B1+10'. Finally I want to copy the 'value in C1 into D1.
Next, I want to copy the 'value' in A2 (in this case the number 2) into cell B1 (again, this is fixed). Then, in C1 the value '12' will appear as it has the formula '=B1+10'. Finally I want to copy the 'value in C1 into D2.
Next, I want to copy the 'value' in A3 (in this case the number 3) into cell B1 (as before). Then, in C1 the value '13' will appear as it has the formula '=B1+10'. Finally I want to copy the 'value in C1 into D3.
And so on. But in my case I need a loop as I will actually have 100s of values in the A-column.

 

[Fluff]

How about

Sub CreateData()

   Dim cnt As Long
   
   For cnt = 1 To Range("A" & Rows.Count).End(xlUp).Row
      Range("A" & cnt).Copy Range("B1")
      Range("D" & cnt).Value = Range("C1").Value
   Next cnt
End Sub

 

[driving is fun]

That'a it!

1) And is it possible to make a square table of the results D1, D2, etc.
In practice I will need about a 10o0 results so a table would be more helpful than a long list.

2) What if A1 to A??, B1, C1 and all the D-results were in different sheets?

 

[Fluff]

This will give 10 columns wide, by however many rows. Change the value in red to vary the number of columns.

Sub CreateData()

   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
End Sub

The values in A,B & C need to be on sheet2 & the result will go on sheet1

 

[driving is fun]

Perfect. Many thanks! You saved me a lot of time and headache.