View Single Post
  #4   Report Post  
Posted to microsoft.public.excel.programming
Toppers Toppers is offline
external usenet poster
 
Posts: 4,339
Default Problem with Range and Occurrences

Try this ... apologies for error in first posting as I realised shortly
afterwards I hadn't coded for all occurences.


Sub SearchSelectCopyPaste()
Dim Var
Dim nbr_rng As Range
On Error Resume Next
With Sheets(1)
Var = InputBox(Prompt:="What number? ", Xpos:=10, Ypos:=10)

lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
Set nbr_rng = .Range("B1:B" & lastrow)
Set c = nbr_rng.Find(Var, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
nextrow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
c.Resize(1, 7).Copy Sheets(2).Cells(nextrow, 1)
Set c = nbr_rng.FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With

If Application.CountIf(Sheets(1).Range("B:B"), Var) 1 Then
MsgBox Var & " has more than one owner!"
End If

End Sub


"Telesphore" wrote:

Thank you.

It pastes the first occurence in sheet2.
But we would like to paste all other occurences in sheet2.

Thanks again.

"Toppers" This copies 7 columns, including active cell i.e. car number to
next
available row, starting column A, on sheet2. Change the second number in
RESIZE to alter number of columns copied.

It counts occurences of VAR in Sheets(1) and produces a message if count
1.

HTH

Sub SearchSelectCopyPaste()
Dim Var
On Error Resume Next
With Sheets(1)
Var = InputBox(Prompt:="What number? ", Xpos:=10, Ypos:=10)
Cells.Find(Var).Activate
nextrow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
ActiveCell.Resize(1, 7).Copy Sheets(2).Cells(nextrow, 1)
If Application.CountIf(.Range("B:B"), Var) 1 Then
MsgBox Var & " has more than one owner!"
End If
End With
End Sub

"Telesphore" wrote:

In Sheets(1) we have these columns: CarOwnerName, LicenceNumbers,
LicenceLetters, AmountPaid, etc..
The licence numbers have 3 letters and 3 numbers.
When a car passes in front of us we would like to identify the owner
informations.
So we enter the 3 numbers in the InputBox.
We would like to 1) copy on Sheets(2) the 5 or 6 cells of the adjacent
columns to the active cell 3 numbers found and 2) check if there are the
same 3 numbers for other clients.

Any help woul be apprecciated. Thank you.

Sub SearchSelectCopyPaste()
Dim Var
On Error Resume Next
Var = InputBox(Prompt:="What number? ", Xpos:=10, Ypos:=10)
Cells.Find(Var).Activate
Range(ActiveCell.Offset(?, ?), ActiveCell.Offset(?, ?)).Copy
Selection.Copy
Sheets(2).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub