Copy partial rows with criteria to new workbook identified sheet

[bikergranma]

I am trying to copy partial rows of information from "Book1" workbook to the "Tracking by Job" workbook, the job # worksheet. I've attached the Tracking by Job workbook which will give you an idea of the information I need. Book1 is the same except it has many more columns, which are not needed in the Tracking workbook. I need to copy the information by job. Here's a sample of what I've come up with so far (just one job from one week). I am getting an end if error and Am concerned about the information being added to the next available line on a particular sheet as well as duplicates. Any help you can give would be wonderful.


Sub CopyJobs()
Dim c As Range
Dim j As Integer
Dim wkbkSource As Workbook
Dim wsSource As Worksheet
Dim wkbkTarget As Workbook
Dim wsTarget As Worksheet
Set wkbkSource = Application.Workbooks("Book1.xlsx")
Set wsSource = wkbkSource.Sheets("END 4-8")
Set wkbkTarget = Workbooks.Open("S:\VT Trucking, LLC\Driver Billing\Trucking 2018\Tracking by Job.xlsm")
Set wsTarget = Sheets("Job 180108")
j = 2
If c = "180108" Then
For Each c In Source.Range("H")
Source.Range("A" & c.Row & ":U" & c.Row).Copy Target.Rows(j)
End If
Next c
End Sub

[Paul_Hossler]

Without actually testing it, I think the "If c = ….." was in the wrong place and was intended to be inside the For Each loop, and that was the reason for your "EndIf error"

I also think you intended to increment j to put the next data on the following line



Sub CopyJobs()

Dim c As Range
Dim j As Integer
Dim wkbkSource As Workbook
Dim wsSource As Worksheet
Dim wkbkTarget As Workbook
Dim wsTarget As Worksheet


Set wkbkSource = Application.Workbooks("Book1.xlsx")
Set wsSource = wkbkSource.Sheets("END 4-8")

Set wkbkTarget = Workbooks.Open("S:\VT Trucking, LLC\Driver Billing\Trucking 2018\Tracking by Job.xlsm")
Set wsTarget = Sheets("Job 180108")

j = 2

For Each c In Source.Range("H")
If c = "180108" Then ' <<<<<<<<<<<<<<<<<<<<<<<<<
Source.Range("A" & c.Row & ":U" & c.Row).Copy Target.Rows(j)
j = j +1 ' <<<<<<<<<<<<<<<<<<<<<<<<
End If
Next c


End Sub


BTW, you can use the[#] icon to insert CODE tags and paste your macro between the beginning and the end one. It sets off the macro nicely and does some formatting

[bikergranma]

Thank you for the info Paul...appreciate it.

I'm now getting a "Run-Time error 424" Object required. Debug shows it on - For Each c In Source.Range("H") - line. :eek:

[bikergranma]

Finally got it to work. Can anyone tell me how to get this to loop through all the worksheets of the workbook source?

Thanks



Sub CopyJobs()
Dim c As Range
Dim j As Integer
Dim wkbkSource As Workbook
Dim wsSource As Worksheet
Dim wkbkTarget As Workbook
Dim wsTarget As Worksheet
Set wkbkSource = Application.Workbooks("Trucking Jan-Jun.xlsx")
Set wsSource = wkbkSource.Sheets("END 1-7")
Set wkbkTarget = Workbooks.Open("S:\VT Trucking, LLC\Driver Billing\Trucking 2018\Tracking by Job.xlsm")
Set wsTarget = Sheets("Job 160156")
j = 3
For Each c In wsSource.Range("H:H")
If c = "160156" Then
wsSource.Range("A" & c.Row & ":U" & c.Row).Copy wsTarget.Rows(j)
j = j + 1
End If
Next c
End Sub

[Paul_Hossler]

Again not tested





Sub CopyJobs()

Dim c As Range
Dim j As Integer

Dim wkbkSource As Workbook
Dim wsSource As Worksheet
Dim wkbkTarget As Workbook
Dim wsTarget As Worksheet


Set wkbkSource = Application.Workbooks("Trucking Jan-Jun.xlsx")

Set wkbkTarget = Workbooks.Open("S:\VT Trucking, LLC\Driver Billing\Trucking 2018\Tracking by Job.xlsm")
Set wsTarget = Sheets("Job 160156")


j = 3


For Each wsSource in wkbkSource.Worksheets
For Each c In wsSource.Range("H:H")
If c = "160156" Then
wsSource.Range("A" & c.Row & ":U" & c.Row).Copy wsTarget.Rows(j)
j = j + 1
End If
Next c
Next




End Sub

[Paul_Hossler]

Suggestion:



For Each c In wsSource.Range("H:H")


will check all (million+) cells in H

You might want to find the last row and only do those




Option Explicit

Sub CopyJobs()

Dim i As Long, j As Long, lstRow As Long
Dim wkbkSource As Workbook
Dim wsSource As Worksheet
Dim wkbkTarget As Workbook
Dim wsTarget As Worksheet
Dim sJobNum As String

sJobNum = "Job 160156"

Set wkbkSource = Application.Workbooks("Trucking Jan-Jun.xlsx")
Set wkbkTarget = Workbooks.Open("S:\VT Trucking, LLC\Driver Billing\Trucking 2018\Tracking by Job.xlsm")
Set wsTarget = Sheets(sJobNum)

j = 3

For Each wsSource In wkbkSource.Worksheets
With wsSource

lstRow = .Cells(.Rows.Count, 8).Row

For i = 1 To lstRow
If .Cells(i, 8).Value = sJobNum Then
.Range("A" & i & ":U" & i).Copy wsTarget.Rows(j)
j = j + 1
End If
Next i
End With
Next

End Sub

[bikergranma]

[SOLVED] :bow: Thank you Paul

[bikergranma]

Paul...couldn't get the find lastrow code to work. It would act like it was working, but nothing ever appeared on the corresponding sheet. It's all good. The code that has it check the whole column works. :yes

[Paul_Hossler]

Paul...couldn't get the find lastrow code to work. It would act like it was working, but nothing ever appeared on the corresponding sheet. It's all good. The code that has it check the whole column works. :yes

Well no wonder it didn't work when I made a dumb mistake

Try



lstRow = .Cells(.Rows.Count, 8).End(xlUp).Row



This starts in the last row of Col H and looks towards the top to find the last cell that has data


Will be faster than checking all 1,000,000+ rows