Help with Excel vba loop with some different ways to end it

[gumbygr]

Hi. I am terrible with loops. Would a kind person help turn this bit of code into a loop that can end either at the first blank line in Col A so this can be more efficient than recopying code over and over.

Can this also be separately done by specifying in a prompt or entry or just in the vba itself how many lines it should scan down in Col A?

Thanks a lot!
-Gabriel


Sub CopyTPM2ExcelNew()

' Item 1 start

Range ("A2: A25"). Select Selection.Copy

Range ("D2"). Select

Selection. PasteSpecial Paste:=xlPasteAll, OperationlNone, SkipBlanks:= -

False, Transpose:-True

Range ("A2") . Select

Application. CutCopyMode = False

Range ("A2: A25") - Select Selection. ClearContents

Selection. Delete

Shift:=xlUp

Range ("A2"). Select

'Item 1 end

"Item 2 start

Range ("A2: A25"). Select Selection. Copy

Range ("D3") - Select

Selection. PasteSpecial PastelPasteAll, OperationlNone, SkipBlanks:=

False, Transpose:-True

Range ("A2") - Select

Application. CutCopyMode - False

Range ("A2: A25") -Select Selection. ClearContents

Selection. Delete ShiftlUp

Range ("A2") . Select

' Item 2 end

End Sub

 

[Cubist]

Try on a copy.

Sub CopyTPM2ExcelNew()
   
    Dim currentRow As Long
    Dim pasteRow As Long
    Dim i As Long
    Dim numLines As Long
    Dim response As String
    Dim dataRange As Range
   
    response = InputBox("Enter the number of lines to process:")
    If IsNumeric(response) Then
        numLines = CLng(response)
    Else
        MsgBox "Invalid input. Please enter a numeric value."
        Exit Sub
    End If
   
    currentRow = 2
    pasteRow = 2
   
    For i = 1 To numLines
        If IsEmpty(Cells(currentRow, 1)) Then Exit For
       
        Set dataRange = Range(Cells(currentRow, 1), Cells(currentRow, 1).End(xlDown))
       
        For j = 1 To dataRange.Rows.Count
            Cells(pasteRow, 3 + j).Value = dataRange.Cells(j, 1).Value
        Next j
       
        dataRange.ClearContents
        dataRange.Rows.Delete Shift:=xlUp
        pasteRow = pasteRow + 1
    Next i
   
End Sub

 

[gumbygr]

Try on a copy.

Sub CopyTPM2ExcelNew()
  
    Dim currentRow As Long
    Dim pasteRow As Long
    Dim i As Long
    Dim numLines As Long
    Dim response As String
    Dim dataRange As Range
  
    response = InputBox("Enter the number of lines to process:")
    If IsNumeric(response) Then
        numLines = CLng(response)
    Else
        MsgBox "Invalid input. Please enter a numeric value."
        Exit Sub
    End If
  
    currentRow = 2
    pasteRow = 2
  
    For i = 1 To numLines
        If IsEmpty(Cells(currentRow, 1)) Then Exit For
      
        Set dataRange = Range(Cells(currentRow, 1), Cells(currentRow, 1).End(xlDown))
      
        For j = 1 To dataRange.Rows.Count
            Cells(pasteRow, 3 + j).Value = dataRange.Cells(j, 1).Value
        Next j
      
        dataRange.ClearContents
        dataRange.Rows.Delete Shift:=xlUp
        pasteRow = pasteRow + 1
    Next i
  
End Sub

This works pretty good! Much appreciated. Are you able to post a version that does this without the prompt, that just cycles through 1000 iterations for example?

Thank you.

-Gabriel

 

[Cubist]

Simply change the numLines = 1000.

Sub CopyTPM2ExcelNew()

    Dim currentRow As Long
    Dim pasteRow As Long
    Dim i As Long
    Dim numLines As Long
    Dim dataRange As Range

    ' Set the number of lines to process to 1000
    numLines = 1000

    currentRow = 2
    pasteRow = 2

    For i = 1 To numLines
        If IsEmpty(Cells(currentRow, 1)) Then Exit For
        
        Set dataRange = Range(Cells(currentRow, 1), Cells(currentRow, 1).End(xlDown))
        
        For j = 1 To dataRange.Rows.Count
            Cells(pasteRow, 3 + j).Value = dataRange.Cells(j, 1).Value
        Next j
        
        dataRange.ClearContents
        dataRange.Rows.Delete Shift:=xlUp
        pasteRow = pasteRow + 1
    Next i

End Sub