Advice on simple mod Req

[Ledge]

Hi all, I obtained this code after doing some research but I am not
quite there yet. Would appreciate some ideas on how I can mod this code
to populate columns "A to F" only on the "Order" sheet.

Thanks,
Dean


Public Sub CopyToAnotherSheet()
Dim rCell As Excel.Range
Dim rRow As Excel.Range
Dim wksFound As Excel.Worksheet
Dim wksData As Excel.Worksheet

Dim szLookupVal As String
Dim szRowAddy As String

Dim Lrow As Long


Set wksFound = Sheets("Order") 'Sheet that gets the copied data
Set wksData = Sheets("Database") 'Sheet that contains the data to
search


Lrow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row + 1
If IsEmpty(wksFound.Cells(1, 1)) And Lrow = 2 Then Lrow = 1

szLookupVal = InputBox("Type The APN Number Here Then Press ENTER or
OK", "APN Search", "")
If Len(szLookupVal) = 0 Then Exit Sub

With wksData.Cells

Set rCell = .Find(szLookupVal, , , , , False)
If Not rCell Is Nothing Then

szRowAddy = rCell.Address

Set rRow = rCell

Do

Set rCell = .FindNext(rCell)

Set rRow = Application.Union(rRow, rCell)

rRow.EntireRow.Copy wksFound.Cells(Lrow, 1)

Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy

End If
End With

Set rCell = Nothing
Set rRow = Nothing
Set wksFound = Nothing
Set wksData = Nothing
MsgBox "Item Sent to Order Page"
End Sub

 

[broro183]

Hi Dean,

Change the line,
rRow.EntireRow.Copy wksFound.Cells(Lrow, 1)
to
rRow.Range("a" & rRow.Row & ":F" & rRow.Row).Copy wksFound.Cells(Lrow,
1)

I'm sure there are better methods but this one seems to work.

hth
Rob Brockett
NZ
Always learning & the best way to learn is to experience...

 

[Ledge]

Thanks Rob, it does work however the macro now does not pull the same
information across onto the "order" sheet.

If I could just somehow stop the entire row from populating past column
F.

rRow.EntireRow.Copy wksFound.Cells(Lrow, 1)

Appreciate your assistance

 

[broro183]

Hi Ledge,
Sorry about that, when I gave it a run through I only had a single
occurence of the "APN #" which is why it worked for me.

I've had another look & changed it as shown below:

Public Sub CopyToAnotherSheet()
Dim rCell As Excel.Range
Dim rRow As Excel.Range
Dim wksFound As Excel.Worksheet
Dim wksData As Excel.Worksheet
Dim szLookupVal As String
Dim szRowAddy As String
Dim Lrow As Long
Set wksFound = Sheets("Order") 'Sheet that gets the copied data
Set wksData = Sheets("Database") 'Sheet that contains the data to
Search

Lrow = wksFound.Cells(rows.Count, 1).End(xlUp).Row + 1
If IsEmpty(wksFound.Cells(1, 1)) And Lrow = 2 Then Lrow = 1

szLookupVal = InputBox("Type The APN Number Here Then Press ENTER or
OK", "APN Search", "")
If Len(szLookupVal) = 0 Then Exit Sub

With wksData.Cells
Set rCell = .Find(szLookupVal, , , , , , False) '*
If Not rCell Is Nothing Then
szRowAddy = rCell.Address
Set rRow = rCell

Do
Set rCell = .FindNext(rCell)
Set rRow = Application.Union(rRow, rCell)
Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy
rRow.Resize(rRow.rows.Count, 6).Copy wksFound.Cells(Lrow, 1) '**

End If
End With

Set rCell = Nothing
Set rRow = Nothing
Set wksFound = Nothing
Set wksData = Nothing
MsgBox "Item Sent to Order Page"
End Sub

Comments:
* This was missing a comma, so the false was not lining up with the
"match case" field.
** I think the range selection is now fixed & I have moved the copy
section outside the loop which may (?) help speed the code up because
it was being repeated for every time the macro looped but now it is
just done once when the loop is finished.

I don't know how your data is setup but personally I would use
autofilter on the column that contains the APN # & then copy visible
cells, eg something like the below:
(watch out for the line wrap)

Public Sub AutofilterCopyToAnotherSheet()
Dim wksFound As Excel.Worksheet
Dim wksData As Excel.Worksheet
Dim szLookupVal As String
Dim Lrow As Long
Set wksFound = Sheets("Order") 'Sheet that gets the copied data
Set wksData = Sheets("Database") 'Sheet that contains the data to
Search
Dim rRow As Excel.Range

Lrow = wksFound.Cells(rows.Count, 1).End(xlUp).Row + 1
If IsEmpty(wksFound.Cells(1, 1)) And Lrow = 2 Then Lrow = 1

szLookupVal = InputBox("Type The APN Number Here Then Press ENTER or
OK", "APN Search", "")
If Len(szLookupVal) = 0 Then Exit Sub

If wksData.AutoFilterMode = True Then 'There are better ways of
testing for this.
wksData.Cells.AutoFilter
Else
End If

With wksData
Range("a1").Select
Range(Selection, Cells.SpecialCells(xlLastCell)).AutoFilter
Field:=1, Criteria1:=szLookupVal
Range("A2").Select
Set rRow = Range(Selection, "A" & wksData.Cells(rows.Count,
1).End(xlUp).Row)
rRow.Resize(rRow.rows.Count, 6).SpecialCells(xlCellTypeVisible).Copy
wksFound.Cells(Lrow, 1)
End With
MsgBox "Item Sent to Order Page"
End Sub


This is just a starting point, whereas I think the first macro is fully
functional now - so I hope it helps.

Rob Brockett
NZ
Always learning & the best way to learn is to experience...