Looping through a cell range and copyign and pasting the data

[Legacy 93538]

Hi

I have this macro which should loop through a cell range row by row and first determine whether the cell is empty and if it is not copy the value and paste it in to column G in another sheet in the same workbook and everytime it pastes it should paste the data into the a new row in column G. However it keeps bringing up an error when it gets to the line highlighted it red below:

 Sub PP3InputRef()
Dim StrFldr As String
Dim PPWB As Workbook
Dim cells As Variant
Dim lNextRow As Long
 
Application.DisplayAlerts = False
 
StrFldr = ThisWorkbook.Path
Set PPWB = Workbooks.Open(StrFldr & "\" & "HDE_PPIII_Input_Reference_Table_V1.xlsx")
 
PPWB.Sheets.Add.Name = ("Input_Reference_Table")
PPWB.Sheets("InputRefapd").Range("A1:Y1").Copy 
 
Destination:=PPWB.Sheets("Input_Reference_Table").Range("A1:Y1")
 
lNextRow = 2
 
For Each cells In Range("A1:U644")
      If cells.Value <> "" Then cells.Copy Destination:=PPWB.Sheets("Input_Reference_Table").Range(lNextRow, 7)
Next cells
 
End Sub

The error is "Application-defined or object-defined error" does anyone know why it keeps causing this error?

Thanks

Jessicaseymour

 

[JackDanIce]

Morning. Try this instead:

Sub PP3InputRef()
 
Dim StrFldr As String
Dim PPWB As Workbook
Dim cells As Range
Dim lNextRow As Long
 
With Application
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
End With
 
StrFldr = ThisWorkbook.Path
Set PPWB = Workbooks.Open(StrFldr & "\" & "HDE_PPIII_Input_Reference_Table_V1.xlsx")
 
PPWB.Sheets.Add.Name = ("Input_Reference_Table")
PPWB.Sheets("InputRefapd").Range("A1:Y1").Copy 
 Destination:=PPWB.Sheets("Input_Reference_Table").Range("A1:Y1")
 
lNextRow = 2
 
For Each cells In Range("A1:U644")
  If len(cells) > 0 "" Then 
    cells.Copy 
    PPWB.Sheets("Input_Reference_Table").Range(lNextRow, 7).PasteSpecial paste:=xlPasteAll
    lNextRow  = lNextRow + 1
  End If
Next cells
 
With Application
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
End With
 
 
End Sub

I added the line in red as I coudn't see how you're copying the value to the next row in your loop - adjust as required.

 

[VoG]

Perhaps

Sub PP3InputRef()
Dim StrFldr As String
Dim PPWB As Workbook
Dim icells As Variant
Dim lNextRow As Long
 
Application.DisplayAlerts = False
 
StrFldr = ThisWorkbook.Path
Set PPWB = Workbooks.Open(StrFldr & "\" & "HDE_PPIII_Input_Reference_Table_V1.xlsx")
 
PPWB.Sheets.Add.Name = ("Input_Reference_Table")
PPWB.Sheets("InputRefapd").Range("A1:Y1").Copy Destination:=PPWB.Sheets("Input_Reference_Table").Range("A1:Y1")
 
lNextRow = 2
 
For Each icells In Range("A1:U644")
      If icells.Value <> "" Then
        icells.Copy Destination:=PPWB.Sheets("Input_Reference_Table").cells(lNextRow, 7)
        lNextRow = lNextRow + 1
End If
Next icells
 
End Sub

 

[Legacy 93538]

Hi

Thanks works withour error now thanks!!!

Been a great help!!