Find & Format Data Using VBA

[Timbo]

Every week I recieve a spreadsheet which I have to sort and analyse.

The code below is very basic and does what I want it to but I need it
to be more flexible.

In Column A there are personal ID Numbers. In the first part of code
below 201 refers to a person I have called Fred, in the second part 205
refers to a person I have called Bill.

I sort the worksheet by ID Number so all of the 201's are at the top
906 is at the bottom and loads of numbers are missing in bewteen.

Variables: There are varying numbers of entries for each code so there
could be 100 201's and 50 205's this week and 30 201's and 20 205's next
week.

Some weeks some ID Numbers may not appear at all i.e. this week 205 may
be in the worksheet next week it might not.

This is my problem the macro works fine until there is a week when an
ID Number doesn't appear then it falls over.

Can anyone suggest a way around please or some alternative code?



Code:
--------------------
Selection.Find(What:="201", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
ActiveCell.Offset(Row_No + 1, 0).Select
ActiveCell.Value = "FRED"
Range(Selection, Cells(ActiveCell.Row, 1)).Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
ActiveCell.Columns("A:A").EntireColumn.Select

Selection.Find(What:="205", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Value = "BILL"
Range(Selection, Cells(ActiveCell.Row, 1)).Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
ActiveCell.Columns("A:A").EntireColumn.Select

 

[Jacob Skaria]

Dear Timbo

Place this condition on top of each section. This will return the number of
instances of your search string

If WorksheetFunction.CountIf(Columns(1), "205") > 0 Then
'Wirte code here
End If


If this post helps click Yes

 

[meh2030]

Every week I recieve a spreadsheet which I have to sort and analyse.

The code below is very basic and does what I want it to but I need it
to be more flexible.

In Column A there are personal ID Numbers. In the first part of code
below 201 refers to a person I have called Fred, in the second part 205
refers to a person I have called Bill.

I sort the worksheet by ID Number so all of the 201's are at the top
906 is at the bottom and loads of numbers are missing in bewteen.

Variables: There are varying numbers of entries for each code so there
could be 100 201's and 50 205's this week and 30 201's and 20 205's next
week.

Some weeks some ID Numbers may not appear at all i.e. this week 205 may
be in the worksheet next week it might not.

This is my problem the macro works fine until there is a week when an
ID Number doesn't appear then it falls over.

Can anyone suggest a way around please or some alternative code?

Code:
--------------------
        Selection.Find(What:="201", After:=ActiveCell, LookIn:=xlFormulas, _        LookAt:=xlPart, SearchOrder:=xlByRows,SearchDirection:=xlNext, _
  MatchCase:=False).Activate
  ActiveCell.Select
  Selection.EntireRow.Insert
  Selection.EntireRow.Insert
  ActiveCell.Offset(Row_No + 1, 0).Select
  ActiveCell.Value = "FRED"
  Range(Selection, Cells(ActiveCell.Row, 1)).Select
  Selection.Font.Bold = True
  Selection.Font.Underline = xlUnderlineStyleSingle
  ActiveCell.Columns("A:A").EntireColumn.Select

  Selection.Find(What:="205", After:=ActiveCell, LookIn:=xlFormulas, _
  LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,_
  MatchCase:=False).Activate
  ActiveCell.Select
  Selection.EntireRow.Insert
  Selection.EntireRow.Insert
  ActiveCell.Offset(1, 0).Range("A1").Select
  ActiveCell.Value = "BILL"
  Range(Selection, Cells(ActiveCell.Row, 1)).Select
  Selection.Font.Bold = True
  Selection.Font.Underline = xlUnderlineStyleSingle
  ActiveCell.Columns("A:A").EntireColumn.Select

Timbo,

I haven't tested this in its entirety, but there should be enough
coding here for you to do what you want. Feel free to alter it to fit
your specifications. (Be sure that you make the appropriate changes
for rngID and rngLookup. I simply did some generic ranges for this in
a mock up spreadsheet).

Best,

Matt Herbert

Sub CustomFind()

Dim rngID As Range
Dim rngSortID As Range
Dim rngCell As Range
Dim colNoRepeats As New Collection
Dim lngJ As Long
Dim lngK As Long
Dim varCurr As Variant
Dim varNext As Variant
Dim varItem As Variant
Dim rngFound As Range
Dim rngFirstFound As Range
Dim rngLastCell As Range
Dim rngListFound As Range
Dim intInsertRows As Integer
Dim intI As Integer
Dim rngLookup As Range

'this is the area where the program will look for the IDs
Set rngID = Range("a1", Cells(Columns("A").Cells.Count, 1).End(xlUp))

'this is the area where you have a lookup table, i.e. the left column
''has ID numbers and the column right next to, and directly to the
right of,
''the left column has the name of the person who corresponds to the
''ID
Set rngLookup = Worksheets("Sheet2").Range("a1").CurrentRegion

'number of rows to insert above the ID
intInsertRows = 2

'create a collection WITHOUT repeats
''adding a repeat Key argument to a colleciton creates an error;
''by resuming next when the error occurs, the item is NOT added
''to the collection; therefore, no repeats are added to the
''collection
On Error Resume Next
For Each rngCell In rngID.Cells
colNoRepeats.Add Item:=rngCell.Value, Key:=CStr(rngCell.Value)
Next

'reset error checking back to normal
On Error GoTo 0

'get the last cell of the rngID
Set rngLastCell = rngID.Cells(rngID.Cells.Count)

'loop through the collection, or IDs, to find all occurances
For Each varItem In colNoRepeats
'see "Remarks" in Find Method documentation
Set rngFound = rngID.Find(What:=varItem, After:=rngLastCell,
LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows)

If Not rngFound Is Nothing Then

'rngFirstFound acts as a "marker" to identify when we have
looped through
''all possible finds, i.e. we are back at the beginning again
Set rngFirstFound = rngFound

'if there is only one item that is found then the one item is
the result
''of the find
Set rngListFound = rngFound

'get the next find; this may or may not exist
Set rngFound = rngID.FindNext(After:=rngFound)

'loop for all possible finds
Do
'this is to catch if there is one item found as well as to
''determine if we are at the beginning "marker" of our
''find list
If rngFound.Address = rngFirstFound.Address Then
Exit Do
End If

'this is to add the multiple found ranges into the
rngListFound;
''union appends the new found item range to the existing
found
''item range
Set rngListFound = Application.Union(rngListFound,
rngFound)

'since we are in a loop, we need to set the rngFound to
the next
''find; this may or may not exist
Set rngFound = rngID.FindNext(After:=rngFound)
Loop
End If

'insert the desired rows, add the name that corresponds to the ID,
and add
''formatting
For intI = 1 To intInsertRows
rngListFound.EntireRow.Insert
If intI = intInsertRows Then
With rngListFound
.Offset(-1, 0).Value =
Application.WorksheetFunction.VLookup(varItem, rngLookup, 2, False)
.Offset(-1, 0).Font.Bold = True
.Offset(-1, 0).Font.Underline = xlUnderlineStyleSingle
End With
End If
Next

'expand the rngID to now include the expanded range (due to the
row insertion)
Set rngID = Range("a1", Cells(Columns("A").Cells.Count, 1).End
(xlUp))
Next

End Sub