Copy and paste rows with a criteria

[JannetteChristie]

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

 

[Kaper]

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.

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

 

[JannetteChristie]

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.

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

 

[JannetteChristie]

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 ??

 

[MARK858]

All the records are being copied to the Misc sheet ??

That's what the lines below tell it to do

Set wsDest = Worksheets("Misc")

.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

 '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

 

[JannetteChristie]

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 Number	Name	Product group	Item Description	Quantity
41-005409-000	Pressure Gauge 4” Dial 0-200 psi(14 bar) Connection 3/8” BSP	WCOMP
41-005410-000	Pressure Gauge **** 16 Bar Brass Connection 3/8" F/F	WCOMP
41-005411-000	U-Syphon 3/8"	WCOMP
41-008200-000	Grundfos TPD 40-300/2 A-F-A-BQQE-JW1 Twin Circulator Pump	WCOMP	Grundfos TPD 40-300/2 A-F-A-BQQE-JW1 Twin Circulator Pump
41-008234-000	63mm Temperature Gauge 0-120Deg Rear Entry	WCOMP	63mm Temperature Gauge 0-120Deg Rear Entry

RF Sheets

Stock item code	Name	Product group	Item Description	Reference Count
31-010795-000	1
20006	WRAS IBC Gasket DN80, 1.5mm PN16	WCOMP	4
31-009196-000	Pipe Fabrication DN80-40 Tru-Bore 2mm Stainless Steel 316	WCOMP	Pipe Fabrication DN80-40 Tru-Bore 2mm Stainless Steel 316	1
31-010626-000	Pipe Fabrication DN80 Tru-Bore 2mm Stainless Steel 316	WCOMP	Pipe Fabrication DN80 Tru-Bore 2mm Stainless Steel 316	1

 

[MARK858]

Hi @JannetteChristie that is unrelated to your original question and so you should start a new thread

 

[JannetteChristie]

That's what the lines below tell it to do

Set wsDest = Worksheets("Misc")

.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

 '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

 

[JannetteChristie]

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

 

[JannetteChristie]

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