The data on sheets 1 thru 30 looks like this:
L 2800 33/2 PP2-1 CIRCUIT
3 el-swch
pd-recep
I want the macro to go through and find CIRCUIT in column G, copy cells A thru D on that row and paste to Worksheet("Circuit") on the next available row. I have most of the code done but keep running into errors. Could someone out there please look this over and offer some assistance?
Here is the code:
Thank you very much,
Murph
L 2800 33/2 PP2-1 CIRCUIT
3 el-swch
pd-recep
I want the macro to go through and find CIRCUIT in column G, copy cells A thru D on that row and paste to Worksheet("Circuit") on the next available row. I have most of the code done but keep running into errors. Could someone out there please look this over and offer some assistance?
Here is the code:
Code:
Sub Circuit()
Dim oSheet As Variant
Dim sht As Integer
Dim Firstcell As Range
Dim cRow As Integer
Dim nRow As Integer
Dim pRow As Integer
Dim dest As Range
Dim NextCell As Range
Dim WhatToFind As Variant
WhatToFind = "CIRCUIT"
For sht = 1 To 30
oSheet = "Sheet" & sht
Worksheets(oSheet).Activate
Worksheets(oSheet).[g1].Activate
Set Firstcell = Cells.Find(What:=WhatToFind, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Firstcell Is Nothing Then
cRow = Firstcell.Row
pRow = Worksheets("Circuit").Range("A65536").End(xlUp).Offset(1, 0)
dest = Worksheets("Circuit").Range("A" & pRow & ":D" & pRow)
Range("a" & cRow & ":D" & cRow).Copy (dest)
On Error Resume Next
While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address)
Set NextCell = Cells.FindNext(After:=ActiveCell)
If Not NextCell.Address = Firstcell.Address Then
nRow = NextCell.Row
pRow = Worksheets("Circuit").Range("A65536").End(xlUp).Offset(1, 0)
dest = Worksheets("Circuit").Range("A" & pRow & ":D" & pRow)
Range("a" & cRow & ":D" & cRow).Copy (dest)
End If
Wend
End If
Set NextCell = Nothing
Set Firstcell = Nothing
Next sht
End Sub
Thank you very much,
Murph