Loop VBA macro

[jcbetanzos]

Hello,

I need help with the following Macro:

Sheets("Sheet1").Activate
ActiveSheet.Range("E2:H2").Select
Selection.Copy
ActiveSheet.Range("E3").Activate
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop
Selection.PasteSpecial xlPasteAll

So basically, this macro copy the content for the range E2 to H2, then every time is active paste the content in column E, starting in the cell E3 only if the cell is empty.

The only thing is that I need to click on the macro to copy and paste the content of the range E2 to H2 and I want to know a way to do this automatically.

Something like:

if column A has values from the cell A2 to the A9, then copy the range E2 to H2 and paste it from the cell E3 to E9,
depending how many values have column A, if have values from cell A2 to A1788, then copy the range E2 to H2 and paste it starting in the cell E3 to E1788.

 

[yky]

The code checks E3 and down to find empty cells then copy and paste but you need now check column A to find non-empty cells for copying and pasting? Just want to make sure before spending time working on it.

 

[Fluff]

Hi & welcome to MrExcel
Is this what you want

Sub CopyPaste()
   Range("E2:H2").Copy Range("E3", Range("A" & Rows.Count).End(xlUp).Offset(, 4)).SpecialCells(xlBlanks)
End Sub

 

[jcbetanzos]

Yes, I created a different VBA code for this:

Sub hn()
'unprotect the workbook
    ActiveSheet.Unprotect
'
Application.ScreenUpdating = False
'
'
    Sheets("EXTERNAL LABELS").Activate
If Range("B2") = "" Then
    msgbox "Please add a valid Part Number and try Again"
    '
    ElseIf Range("B3") = "" Then
    msgbox "Please add a valid Part Number and try Again"
    '
    Else
    Range("E2:H2").AutoFill Destination:=Range("(E2:H2):E" & Range("B" & Rows.Count).End(xlUp).Row)
End If
        '
        '
'Delete all empty rows.
If Not IsEmpty(ActiveCell.Value) Then
    '   Find last row on sheet
    myLastRow = Range("B2").SpecialCells(xlLastCell).Row
    '   Find all blank values in column B and delete those rows
    Range("B2:B" & myLastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
'
Application.ScreenUpdating = True
'Activate protection
'
    ActiveSheet.Protect
    ActiveWorkbook.Protect Structure:=True, Windows:=False
'save the changes made
    ActiveWorkbook.Save
'
End Sub

So basically what it does is autofill the range E2:H2 to the last active cells from the column B, then search for all the empty cells in column B and delete all the empty row.
But what I want is when I click "copy" only to copy the range E2:H2 in the active cells of column B.
Any Idea?

 

[Fluff]

What do you mean by

the active cells of column B.

 

[jcbetanzos]

What do you mean by

in all the non-empty cells.

 

[Fluff]

Try

Sub CopyPaste()
   range("E2:H2").Copy range("B3", range("A" & Rows.Count).End(xlUp).Offset(, 1)).SpecialCells(xlBlanks).Offset(, 3)
End Sub

 

[jcbetanzos]

Try

Sub CopyPaste()
   range("E2:H2").Copy range("B3", range("A" & Rows.Count).End(xlUp).Offset(, 1)).SpecialCells(xlBlanks).Offset(, 3)
End Sub

Thank You for the help, however, the code didn't work

this was the one that I found and is working fine!

Code:

Sub hn()
Range("E2:H2").Copy Destination:=Range("(E2:H2):E" & Range("B" & Rows.Count).End(xlUp).Row)
End Sub

The only problem is if I run the code without any value in cell B2 it copy the range (E2:H2) to (E1:H1) and mess everything.
To avoid this I add this IF statement:
Code:

If Range("B2") = "" Then
    MsgBox "Please add a valid Part Number in cell B2 and try Again"
    Exit Sub
    '
    Else
    Range("E2:H2").Copy Destination:=Range("(E2:H2):E" & Range("B" & Rows.Count).End(xlUp).Row)
End If

Please let me know if you guys have a better idea to improve this code