Copy and paste rows with a criteria

JannetteChristie

Board Regular
Joined
Dec 14, 2015
Messages
137
Office Version
  1. 365
Hi,

Hoping someone can help me out here.
I am trying to loop through the worksheets called PP-RF*, read the contents in Column A and then copy the record to a named sheet.
This code loops through the worksheet names:

Sub ForEachWs()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

If ws.Name Like "*" & "RF" & "*" Then

MoveRecsToSheet ws

End If

Next ws

End Sub

I am having trouble with the copying of the record to the named sheet

Sub MoveRecsToSheet(ws As Worksheet)

Dim c As Integer
Dim x As Integer
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim Sheetname As String
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

Application.ScreenUpdating = False

Set wsCopy = Worksheets(ws.Name)
Set wsDest = Worksheets("Pipe")
Sheetname = ws.Name
Sheets(Sheetname).Select

lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

c = 2
For x = 1 To lCopyLastRow

If InStr(1, Range("B" & c).Value, "31-") > 0 Then

Sheets(ws.Name).Cells(x, 1).EntireRow.Copy


lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(x1Up).Offset(1).Row
Range("A" & lDestLastRow).Select
Selection.PasteSpecial

Sheets(Sheetname).Select

End If

c = c + 1

ActiveCell.Offset(1, 0).Select
Next


Application.ScreenUpdating = True

End Sub
Select method of worksheet class failed
 
This shall be enough for the second procedure. And as to sheets are selected, probably you don't have to swith screen updating off during it.

VBA Code:
Sub MoveRecsToSheet(ws As Worksheet)
Dim x As Long
Dim wsDest As Worksheet
Dim lCopyLastRow As Long

Set wsDest = Worksheets("Pipe")
With ws
  For x = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
    If InStr(1, .Range("B" & x + 1).Value, "31-") > 0 Then
      .Cells(x, 1).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).EntireRow
    End If
  Next x
End With

Set wsDest = Nothing
End Sub
 
Upvote 0
This shall be enough for the second procedure. And as to sheets are selected, probably you don't have to swith screen updating off during it.

VBA Code:
Sub MoveRecsToSheet(ws As Worksheet)
Dim x As Long
Dim wsDest As Worksheet
Dim lCopyLastRow As Long

Set wsDest = Worksheets("Pipe")
With ws
  For x = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
    If InStr(1, .Range("B" & x + 1).Value, "31-") > 0 Then
      .Cells(x, 1).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).EntireRow
    End If
  Next x
End With

Set wsDest = Nothing
End Sub
 
Upvote 0
Hi @Kaper

I changed the second procedure to the following
Sub MoveRecsToSheetNew(ws As Worksheet)

Dim x As Long
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Sheetname = ws.Name
Sheets(Sheetname).Select

With ws
If InStr(1, .Range("B" & x + 1).Value, "31-") > 0 Then
Set wsDest = Worksheets("Pipe")
End If

'ElseIf InStr(1, .Range("B" & x + 1).Value, "41-") > 0 Then
If InStr(1, .Range("B" & x + 1).Value, "41-") > 0 Then
Set wsDest = Worksheets("Parts")
Else
Set wsDest = Worksheets("Misc")
End If

'With ws
For x = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
'If InStr(1, .Range("B" & x + 1).Value, "31-") > 0 Then
.Cells(x, 1).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).EntireRow
' End If
Next x
End With

Set wsDest = Nothing

End Sub
All the records are being copied to the Misc sheet ??
 
Last edited:
Upvote 0
All the records are being copied to the Misc sheet ??
That's what the lines below tell it to do
Rich (BB code):
Set wsDest = Worksheets("Misc")
Rich (BB code):
.Cells(x, 1).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).EntireRow

It will copy all as you have commented out any test for when it will/won't apply

Rich (BB code):
 'If InStr(1, .Range("B" & x + 1).Value, "31-") > 0 Then

and so will use that as it is looping all the cells, your first 2 tests are outside the loop and so will only test B1 and so if B1 doesn't contain "41-" then it will paste all rows to Worksheets("Misc")

P.S. you don't need the last .EntireRow in the destination part
 
Last edited:
Upvote 0
Thanks for all of your help, all working now.

Just one final thing to complete the task.

I now want to loop through the destination sheets (Parts,Pipes and Misc) and for each product code in Column B get the count from all of the RF sheets column B has the product code, column F has the count and update column F in the destination sheets.

Destination sheets

Part NumberNameProduct groupItem DescriptionQuantity
41-005409-000Pressure Gauge 4” Dial 0-200 psi(14 bar) Connection 3/8” BSPWCOMP
41-005410-000Pressure Gauge **** 16 Bar Brass Connection 3/8" F/FWCOMP
41-005411-000U-Syphon 3/8"WCOMP
41-008200-000Grundfos TPD 40-300/2 A-F-A-BQQE-JW1 Twin Circulator PumpWCOMPGrundfos TPD 40-300/2 A-F-A-BQQE-JW1 Twin Circulator Pump
41-008234-00063mm Temperature Gauge 0-120Deg Rear EntryWCOMP63mm Temperature Gauge 0-120Deg Rear Entry

RF Sheets
Stock item codeNameProduct groupItem DescriptionReference Count
31-010795-0001
20006WRAS IBC Gasket DN80, 1.5mm PN16 WCOMP4
31-009196-000Pipe Fabrication DN80-40 Tru-Bore 2mm Stainless Steel 316WCOMPPipe Fabrication DN80-40 Tru-Bore 2mm Stainless Steel 3161
31-010626-000Pipe Fabrication DN80 Tru-Bore 2mm Stainless Steel 316WCOMPPipe Fabrication DN80 Tru-Bore 2mm Stainless Steel 3161
 
Upvote 0
That's what the lines below tell it to do
Rich (BB code):
Set wsDest = Worksheets("Misc")
Rich (BB code):
.Cells(x, 1).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).EntireRow

It will copy all as you have commented out any test for when it will/won't apply

Rich (BB code):
 'If InStr(1, .Range("B" & x + 1).Value, "31-") > 0 Then

and so will use that as it is looping all the cells, your first 2 tests are outside the loop and so will only test B1 and so if B1 doesn't contain "41-" then it will paste all rows to Worksheets("Misc")

P.S. you don't need the last .EntireRow in the destination part
 
Upvote 0
Hi @MARK858
Thanks for your reply, I have that part working now.

I have posted a response as I am wanting to get the sum of column F from the source sheets to the destination sheets
 
Upvote 0
Hi @Kaper and @MARK858

I have the following code to loop thru the Parts,Pipe and Misc Sheet rows and get the quantities from the RF sheets.

Sub GetQuantity()

Dim ws As Worksheet
Dim x As Long, c As Long, lLastRow As Long
Dim wsString As String
Dim wnCntr As Long

c = 1
For Each ws In Sheets(Array("Parts", "Pipe", "Misc"))

Sheetname = ws.Name
Sheets(Sheetname).Select
lLastRow = Sheets(Sheetname).Cells(Sheets(Sheetname).Rows.Count, "B").End(xlUp).Row

For x = 1 To lLastRow

If Left(Range("B" & x).Value, 3) <> "Par" And Left(Range("B" & x).Value, 3) <> "Sto" Then

wsString = Range("B" & x).Value
wnCntr = 0

QtyWs wsString, wnCntr

Range("F" & x).Value = wnCntr

End If

Next x

c = c + 1
Next

End Sub

Sub QtyWs(wsString As String, wnCntr As Long)

Dim ws As Worksheet
Dim x As Long, lLastRow As Long

For Each ws In ActiveWorkbook.Worksheets

If ws.Name Like "*" & "RF" & "*" Then
lLastRow = Sheets(ws.Name).Cells(Sheets(ws.Name).Rows.Count, "B").End(xlUp).Row

For x = 1 To lLastRow
If Range("B" & x).Value = wsString Then
wnCntr = wnCntr + Range("F" & x).Value
End If

Next x
End If
Next ws


End Sub


The issue is that it is always coming back as 0 - can't see the issue at the moment, are you able to help
 
Upvote 0

Forum statistics

Threads
1,226,771
Messages
6,192,919
Members
453,767
Latest member
922aloose

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