Loop to copy data into new sheet

Rado88

New Member
Joined
Dec 30, 2017
Messages
45
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 :(
 
Last edited:

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
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
Code:
ActiveSheet.paste
with
Code:
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
 
Upvote 0
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.
 
Last edited:
Upvote 0
Hey Rado88,

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

Code:
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
 
Upvote 0
Hey Rado88,

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

Code:
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
 
Last edited:
Upvote 0
My bad, try now

Code:
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
 
Upvote 0
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
 
Upvote 0
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

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
 
Upvote 0
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

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 :)
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,549
Messages
6,114,261
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top