Loop to copy data into new sheet

[Rado88]

Hi All,

I've a query regarding copying data from Loop into newly added sheet / workbook in excel. For some reasons I can't paste more than one row to new sheet. I modified the code few times but for some reason I can't past all the finding to a new sheet when I don't know it's name

I'm also thinking about adding adding a new workbook option instead of copying to new sheet

What I've:

Sheet A - C with data

Sheet A: Data which will be filtered on base of Sheet C cells value
Sheet C: 3 cells which determine what to copy / delete from sheet A (after user adds values / text in this sheet)

o - will be the number of column where the P value can be found
P - P3 will be updated with text or value by user

What I want to do:
I've a loop which searches for specific data from sheet A and then it should paste it into new sheet, later on it should copy next selection to this new sheet and next... until all rows from sheet meeting the criteria set-up in sheet 3 are met (but only 1 sheet should be added). In short I want to paste all the data meeting requirements from sheet C into new excel sheet in order to help them to get the data they need to work on faster.

The issue:
For now only the first row is copied and pasted into new sheet. I'm not sure how do define the new sheet

Code I've:

Dim o As Long
Dim P As Variant
Dim P2 As Variant
Dim P3 As Variant


o = Worksheets("SheetC").Cells(5, 5).Value


P = Worksheets("SheetC").Cells(5, 9).Value
P2 = Worksheets("SheetC").Cells(8, 9).Value
P3 = Worksheets("SheetC").Cells(11, 9).Value


A = Worksheets("SheetA").Cells(Rows.Count, o).End(xlUp).Row


For i = A To 2 Step -1


If Worksheets("SheetA").Cells(i, o).Value = Z Then


Worksheets("SheetA").Range(Cells(i, 1), Cells(i, 7)).Select


If Worksheets("SheetA").Cells(i, o).Value = P2 And Worksheets("SheetA").Cells(i, o).Value <> "" Then


Worksheets("SheetA").Range(Cells(i, 1), Cells(i, 7)).Select


If Worksheets("SheetA").Cells(i, o).Value = P3 And Worksheets("SheetA").Cells(i, o).Value <> "" Then


Worksheets("SheetA").Range(Cells(i, 1), Cells(i, 7)).Select


End If
End If
End If


Next i

And below is the part which is not working as it should.


Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste

End Sub

I've also replaced . Select at the end of each loop with copy but it didn't wok as only one row was pasted. If only I knew how to tell excel to copy to the newly created sheet / workbook

 

[fhqwgads]

only one row was pasted.

i think the cause of that is that each time the loop runs, it doesnt add the selection to what's already selected but instead makes a new selection of only those cells. maybe move the copy paste code within the loop and the add new sheet code before the loop.
you may need to replace

ActiveSheet.paste

with

ActiveSheet.Rows(1).Insert Shift:=xlDown

so your pasting doesnt paste over your data each time it loops

sorry i cant give you the exact code you need, i'm still learning vba myself

 

[Rado88]

Hi fhqwgads

I also tried this method, as well as the below, but i still can't copy all the results into new workbook, worksheet.

Dim Wos As Worksheet

Set Wos = ThisWorkbook.Sheets.Add

With Wos


Wos.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=clNone, SkipBlanks:=False, Transpose:=False


End With


However thank you very much for your help.

 

[mse330]

Hey Rado88,

I have revised your code based on my understanding of your requirements. Give it a shot & let me know if it works

Sub Test()
Dim Rg As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("SheetA")
Set ws2 = Worksheets("SheetC")
Set ws3 = Sheets.Add(After:=Sheets(Sheets.Count))
Dim o As Long, P As Variant, P2 As Variant, P3 As Variant, lRow As Long
With ws2
    o = .Cells(5, 5)
    P = .Cells(5, 9)
    P2 = .Cells(8, 9)
    P3 = .Cells(11, 9)
End With
lRow = ws1.Cells(Rows.Count, o).End(xlUp).Row
For i = lRow To 2 Step -1
    If ws1.Cells(i, o).Value = Z Then ' What is Z ? It's not defind as variable & I don't see a value assigned to it
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value
    ElseIf ws1.Cells(i, o).Value = P2 And ws1.Cells(i, o).Value <> "" Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value
    ElseIf ws1.Cells(i, o).Value = P3 And ws1.Cells(i, o).Value <> "" Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value
    End If
    lRow = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws3.Range(Cells(lRow, 1), Cells(lRow, 7)).Value = Rg.Value
Next i
End Sub

 

[Rado88]

Hey Rado88,

I have revised your code based on my understanding of your requirements. Give it a shot & let me know if it works

Sub Test()
Dim Rg As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("SheetA")
Set ws2 = Worksheets("SheetC")
Set ws3 = Sheets.Add(After:=Sheets(Sheets.Count))
Dim o As Long, P As Variant, P2 As Variant, P3 As Variant, lRow As Long
With ws2
    o = .Cells(5, 5)
    P = .Cells(5, 9)
    P2 = .Cells(8, 9)
    P3 = .Cells(11, 9)
End With
lRow = ws1.Cells(Rows.Count, o).End(xlUp).Row
For i = lRow To 2 Step -1
    If ws1.Cells(i, o).Value = Z Then ' What is Z ? It's not defind as variable & I don't see a value assigned to it
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value
    ElseIf ws1.Cells(i, o).Value = P2 And ws1.Cells(i, o).Value <> "" Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value
    ElseIf ws1.Cells(i, o).Value = P3 And ws1.Cells(i, o).Value <> "" Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value
    End If
    lRow = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws3.Range(Cells(lRow, 1), Cells(lRow, 7)).Value = Rg.Value
Next i
End Sub

Hi

Thank you for your help mse330

The Z was a typo from my side. I'm sorry for this, as it was a late when I was copying this macro It should be P not Z

The macro ends at the below line with error 1004 Method range of object Worksheet failed

Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7)).Value


The macro should copy the cells from the rows in which they can find P, P1 or P2 (text / value). Later it should paste the results in the new sheet looping (checking if the next row has the required data, then copy it and so on until the last row.


If Worksheets("SheetA").Cells(i, o).Value = P Then


Worksheets("SheetA").Range(Cells(i, 1), Cells(i, 7)).Copy


If Worksheets("SheetA").Cells(i, o).Value = P2 And Worksheets("SheetA").Cells(i, o).Value <> "" Then


Worksheets("SheetA").Range(Cells(i, 1), Cells(i, 7)).Copy


If Worksheets("SheetA").Cells(i, o).Value = P3 And Worksheets("SheetA").Cells(i, o).Value <> "" Then


Worksheets("SheetA").Range(Cells(i, 1), Cells(i, 7)).Copy

Unfortunately it copies only first row and ends there

 

[mse330]

My bad, try now

Sub Test()
Dim Rg As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("SheetA")
Set ws2 = Worksheets("SheetC")
Set ws3 = Sheets.Add(After:=Sheets(Sheets.Count))
Dim o As Long, P As Variant, P2 As Variant, P3 As Variant, lRow As Long
With ws2
    o = .Cells(5, 5)
    P = .Cells(5, 9)
    P2 = .Cells(8, 9)
    P3 = .Cells(11, 9)
End With
lRow = ws1.Cells(Rows.Count, o).End(xlUp).Row
For i = lRow To 2 Step -1
    If ws1.Cells(i, o).Value = P Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7))
    ElseIf ws1.Cells(i, o).Value = P2 And ws1.Cells(i, o).Value <> "" Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7))
    ElseIf ws1.Cells(i, o).Value = P3 And ws1.Cells(i, o).Value <> "" Then
        Set Rg = ws1.Range(Cells(i, 1), Cells(i, 7))
    End If
    lRow = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws3.Range(Cells(lRow, 1), Cells(lRow, 7)).Value = Rg.Value
Next i
End Sub

 

[Rado88]

Unfortunately I still receive the same issue at the same place

 

[Rado88]

Unfortunately I still receive the same issue at the same place

I tried to modify the code by it still doesn't work it creates a new sheet but ends up on the same line with error 1004.

For some reason like my code it doesn't want to copy the data from sheetA

 

[mse330]

It was late last night & I was just writing the code. I have just put a sample data on a file & made some adjustments which should solve the error you were getting

Try the revised below code

Sub Test()
Dim Rg As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, Flg As Boolean
Set ws1 = Worksheets("SheetA")
Set ws2 = Worksheets("SheetC")
Set ws3 = Sheets.Add(After:=Sheets(Sheets.Count))
Dim o As Long, P As Variant, P2 As Variant, P3 As Variant, lRow As Long
With ws2
    o = .Cells(5, 5)
    P = .Cells(5, 9)
    P2 = .Cells(8, 9)
    P3 = .Cells(11, 9)
End With
lRow = ws1.Cells(Rows.Count, o).End(xlUp).Row
For i = lRow To 2 Step -1
    With ws1
        If ws1.Cells(i, o).Value = P Then
            Set Rg = Range(.Cells(i, 1), .Cells(i, 7))
            Flg = True
        ElseIf ws1.Cells(i, o).Value = P2 And ws1.Cells(i, o).Value <> "" Then
            Set Rg = Range(.Cells(i, 1), .Cells(i, 7))
            Flg = True
        ElseIf ws1.Cells(i, o).Value = P3 And ws1.Cells(i, o).Value <> "" Then
            Set Rg = Range(.Cells(i, 1), .Cells(i, 7))
            Flg = True
        End If
    End With
        If Flg = True Then
            lRow = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
            Range(ws3.Cells(lRow, 1), ws3.Cells(lRow, 7)) = Rg.Value
            Flg = False
        End If
Next i
End Sub

 

[Rado88]

It was late last night & I was just writing the code. I have just put a sample data on a file & made some adjustments which should solve the error you were getting

Try the revised below code

Sub Test()
Dim Rg As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, Flg As Boolean
Set ws1 = Worksheets("SheetA")
Set ws2 = Worksheets("SheetC")
Set ws3 = Sheets.Add(After:=Sheets(Sheets.Count))
Dim o As Long, P As Variant, P2 As Variant, P3 As Variant, lRow As Long
With ws2
    o = .Cells(5, 5)
    P = .Cells(5, 9)
    P2 = .Cells(8, 9)
    P3 = .Cells(11, 9)
End With
lRow = ws1.Cells(Rows.Count, o).End(xlUp).Row
For i = lRow To 2 Step -1
    With ws1
        If ws1.Cells(i, o).Value = P Then
            Set Rg = Range(.Cells(i, 1), .Cells(i, 7))
            Flg = True
        ElseIf ws1.Cells(i, o).Value = P2 And ws1.Cells(i, o).Value <> "" Then
            Set Rg = Range(.Cells(i, 1), .Cells(i, 7))
            Flg = True
        ElseIf ws1.Cells(i, o).Value = P3 And ws1.Cells(i, o).Value <> "" Then
            Set Rg = Range(.Cells(i, 1), .Cells(i, 7))
            Flg = True
        End If
    End With
        If Flg = True Then
            lRow = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
            Range(ws3.Cells(lRow, 1), ws3.Cells(lRow, 7)) = Rg.Value
            Flg = False
        End If
Next i
End Sub

Thank you very much for your help mse330 but the above code copied only the fist row like my macro.

I managed to figure out how to make this macro work now by adding the below lines into the code from my first post.

x = (Sheets.add worksheet).Cells(Rows.Count, o).End(xlUp).Row
(Sheets.add worksheet).Cells(x + 1, 1).Select
ActiveSheet.Paste

This somehow triggered the macro to paste all the results

Thank you for your help