How to increment by 1 a loop in Visual Basic for Application - excel

Question

My first question on Stackoverflow, and a newbe, so please bare with me.
I am trying to sort out an excel sheet with 411,278 rows, about stock market data.
My code is as follows:
Sub Macro1()
'
' Macro1 Macro
'
Range("C6:C1577").Select
Selection.Copy
Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B6:C1577").Select
Range("C6").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
I am trying to insert the above code in a loop that will increment all the numbers within the loop by 1.
For example (the next phase in the loop will be):
Sub Macro1()
'
' Macro1 Macro
'
Range("C7:C1578").Select
Selection.Copy
Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B7:C1578").Select
Range("C7").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
Thanks!

Answer 1

A Data Transpose
The following will copy only the values (no formatting or formulas).
Adjust the values in the constants section. Note that you can choose a different worksheet for the result to leave your source data intact.
The Code
Option Explicit
Sub transposeValues()
' Define constants.
Const srcName As String = "Sheet1"
Const srcColumns As String = "B:D"
Const srcFirstRow As Long = 5
Const dstName As String = "Sheet1"
Const dstFirstCell As String = "B5"
Const dCount As Long = 1573
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim rng As Range
With wb.Worksheets(srcName).Columns(srcColumns)
Set rng = .Resize(.Worksheet.Rows.Count - srcFirstRow + 1) _
.Offset(srcFirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - srcFirstRow + 1).Offset(srcFirstRow - 1)
End With
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Define Result Array.
Dim srCount As Long: srCount = UBound(Data)
Dim Remainder As Long: Remainder = srCount Mod dCount
Dim drCount As Long
If Remainder = 0 Then
drCount = srCount / dCount
Else
drCount = Int(srCount / dCount) + 1
End If
Dim dcCount As Long: dcCount = dCount + 1
Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
' Declare counters.
Dim i As Long, j As Long, k As Long
' Write values from Data Array to Result Array.
If drCount = 1 And Remainder > 0 Then
i = 1
Else
For i = 1 To drCount + (Remainder <> 0) * 1 ' In VBA 'True = -1'.
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
For j = 3 To dcCount
k = k + 1
Result(i, j) = Data(k, 2)
Next j
Next i
End If
' Write the remainder of values in Data Array to Result Array.
If Remainder > 0 Then
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
If Remainder > 1 Then
For j = 3 To 1 + Remainder
k = k + 1
Result(i, j) = Data(k, 2)
Next j
End If
End If
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirstCell).Resize(, dcCount)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(drCount).Value = Result
End With
End Sub

Answer 2

Please do not try this code without taking precautions.
Sub Macro1()
Dim Rng As Range
Dim Rstart As Long ' start of range row
Dim Rend As Long ' end of range row
Dim Target As Range ' destination of copy action
Dim DelRng As Range ' range to delete
Rstart = 6
Rend = 1577
Application.ScreenUpdating = False
Do
Set Rng = Range(Cells(Rstart, "C"), Cells(Rend, "C"))
Set Target = Cells(Rstart - 1, "D")
Set DelRng = Range(Cells(Rstart, "B"), Cells(Rend, "C"))
Rng.Copy
TargetPasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
DelRng.Delete Shift:=xlUp
Rstart = Rstart + 1
Loop Until Rstart = Rend
With Application
.CutCopyMode = False
.ScreenUpdating = False
End With
End Sub
Primary precaution to take is to understand the code. Start and End rows are specified at the top. They are used to set 3 ranges in columns C, D and B:C. Initially, they are precisely your 3 ranges Range("C6:C1577"), Range("D5"), Range("B6:C1577"). The code copies from the first range to the second and then deletes the third. It does so without selecting anything because once VBA is told where a range is it doesn't need to select it.
You will notice that there is no equivalent of your Range("C7").Activate. That's because C7 is within the range Range("B6:C1577") which is earmarked for destruction. It makes no difference which cell in it is active. However, I have some doubt about the deletion and whether you actually meant to delete only this cell (which your code doesn't do). Please check my code against your intentions in this regard.
Now the critical part. That's the loop. On each iteration the 3 ranges are moved one row down. The line of code requiring your attention is this one.
Loop Until Rng.Row = Rend
The loop will continue until the first row of the first range is equal to Rend. That means that there will be 1571 loops - probably enough time to have a coffee and a chat even while screen updating is turned off. But even this fearsome number is definitely wrong. Your question gives no clue as to your needs but I guess it should be like Loop Until Rng.Row = (411278 - Rend), give or take 1. I didn't want to enter into an argument about this final, last row (which tends to be omitted in loops) while not believing that your number of rows is invariable. I think it should be replaced with a formula that finds the last existing row in a particular column.
However, your question was how to advance the ranges. My code does that beautifully. Enjoy the show.