VBA to increase cell value by 1 and loop code

[jbench18]

Hi all, I have the code below that works as needed, but I'm looking at enhancing it further. I want run the code below, and then have cell F5 increase by 1 and then rerun the code below. I want to do this until F5 hits 40. Appreciate any help and assistance.

Range("P8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("Upload").Range("A" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With


Range("Q8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("Upload").Range("A" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With


Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("Upload").Range("B" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With


Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("Upload").Range("B" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With


Range("M8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("Upload").Range("C" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With


Range("M8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
With Sheets("Upload").Range("C" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With

 

[DanteAmor]

Try this

Sub Increase()
    Dim i As Double
    
    Application.ScreenUpdating = False


    For i = 1 To 40
    
        Range("F5").Value = i
        
        Range("P8").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        With Sheets("Upload").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
        
        Range("Q8").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        With Sheets("Upload").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
    
        Range("A8").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        With Sheets("Upload").Range("B" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
        
        Range("A8").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        With Sheets("Upload").Range("B" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
        
        Range("M8").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        With Sheets("Upload").Range("C" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
        
        Range("M8").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        With Sheets("Upload").Range("C" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
    Next


    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    
    MsgBox "Finish"
End Sub

 

[jbench18]

Hi Dante works perfect! Appreciate the quick response and help.

 

[kang23]

Hi jbench

Few ways to do this, I'd use a while loop.

Dim i As Integer

i = Range("F5").Value


While i <= 40


'Put youre code here


Range("F5") = Range("F5") + 1
i = Range("F5").Value




Wend




End Sub

 

[kang23]

beaten to the punch!

 

[DanteAmor]

Hi Dante works perfect! Appreciate the quick response and help.

I'm glad to help you. I appreciate your kind comments.


Summary Code:

Sub Increase()
    Dim i As Double
    
    Application.ScreenUpdating = False


    For i = 1 To 40
    
        Range("F5").Value = i
        
        Range("P8", Range("P8").End(xlDown)).Copy
        Sheets("Upload").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        
        Range("Q8", Range("Q8").End(xlDown)).Copy
        Sheets("Upload").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        
        Range("A8", Range("A8").End(xlDown)).Copy
        Sheets("Upload").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        Sheets("Upload").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        
        Range("M8", Range("M8").End(xlDown)).Copy
        Sheets("Upload").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        Sheets("Upload").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        
    Next


    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    
    MsgBox "Finish"
End Sub