Looping through a cell range and copy cell value to seperate sheet

[Legacy 93538]

Hi

I have this macro and it should opena document, create a new sheet, copy data from one sheet to the new sheet, then open the "PPIIIFORM" sheet and loop through the cell range "F4:U644" and check and if the cell has a text value copy the value and paste into another sheet in column a and continue to next cell and repeat process but for each new cell i need it to paste it into the next cell in column a.

This is what i have so far but it does not paste the value into the next cell down it pastes the value into the same cell:

Sub PP3InputRef()
Dim StrFldr As String
Dim PPWB As Workbook
Dim cells As Variant
Dim Nrow As Long
Dim Nrow1 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")
PPWB.Sheets("Input_Reference_Table").Select: Columns("A:A").Select

Nrow = 2
 
For Each cells In Sheets("PPIIIFORM").Range("F4:U644")
      If cells.Value <> "" Then Sheets("Input_Reference_Table").cells(Nrow, 1).Value = cells.Value
     Nrow1 = Nrow1 + 1

Next cells
 
End Sub

Can anyone help and show me how to get it to paste the value into a new cell every time?

Thanks

Jessicaseymour

 

[VoG]

Perhaps like this. Avoid using cells as a variable name - it is a VBA keyword

Sub PP3InputRef()
Dim StrFldr As String
Dim PPWB As Workbook
Dim cell As Range
Dim Nrow As Long
Dim Nrow1 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")
PPWB.Sheets("Input_Reference_Table").Select: Columns("A:A").Select

Nrow = 2
 
For Each cell In Sheets("PPIIIFORM").Range("F4:U644")
    If cell.Value <> "" Then
        Sheets("Input_Reference_Table").Cells(Nrow, 1).Value = cell.Value
        Nrow1 = Nrow1 + 1
    End If
Next cell
 
End Sub

 

[Legacy 93538]

Hi

Thanks for replying!

I used to code you sent but it still is pasting the value into the same cell in the Input_Reference_Table sheet.

It should go through the loop, check if the cell has a text value, if so it should copy the value paste it into the cell in the Input_Reference_Table sheet then go onto the next sheet but everytime it pastes it should go to the next row. But when i run it it pastes the values into the same cell.

Thanks

Jessicaseymour

 

[VoG]

Ah!

Sub PP3InputRef()
Dim StrFldr As String
Dim PPWB As Workbook
Dim cell As Range
Dim Nrow As Long
Dim Nrow1 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")
PPWB.Sheets("Input_Reference_Table").Select: Columns("A:A").Select

Nrow = 2
 
For Each cell In Sheets("PPIIIFORM").Range("F4:U644")
    If cell.Value <> "" Then
        Sheets("Input_Reference_Table").Cells(Nrow, 1).Value = cell.Value
        Nrow = Nrow + 1
    End If
Next cell
 
End Sub

 

[Legacy 93538]

Hi

Works perfectly now thanks very much for help i greatly appricate it!!