Macro stops because of blank cells

[mdos1]

I have a great little macro to find and sort individual part names from a list on one sheet and place it in a second, where I then do a count and other bits and pieces. The problem I'm having is that the first list could have gaps in the row and if thats the case the macro stops there, I need to to look at at least the next 10 row to make sure it has reached the end of the list.

can anyone help?

Mark

Private Sub CommandButton1_Click()
Dim sIn As Worksheet
Dim sOut As Worksheet
Dim rIn As Integer
Dim cIn As Integer
Dim rOut As Integer
Dim cOut As Integer
Dim Num As Integer
Dim NewValue
Dim Found As Boolean
Dim SearchRange As Range

'set the two worksheets
Set sIn = Sheets("Valve Schedule")
Set sOut = Sheets("Totals")

'start input from F19
rIn = 7

cIn = 7

'start output from A10
rOut = 24
cOut = 1
Num = 0

'clear ouput range
Range(sOut.Cells(rOut, cOut), sOut.Cells(rOut + 1000, cOut)).ClearContents

'this is needed for the Match function which returns an error if not found
On Error Resume Next

'run through input list
Do While sIn.Cells(rIn, cIn).Value <> ""
NewValue = sIn.Cells(rIn, cIn).Value

'try to find the item in the output list
Set SearchRange = Range(sOut.Cells(rOut, cOut), sOut.Cells(rOut + Num, cOut))

Found = False
Found = IsNumeric(Application.WorksheetFunction.Match(NewValue, SearchRange, 0))

'add item to destination
If Not Found Then
sOut.Cells(rOut + Num, cOut).Value = NewValue
Num = Num + 1
End If

rIn = rIn + 1
Loop

On Error GoTo 0

MsgBox "Completed processing. Unique items written:" + Str(Num)

' Sub SORT()
'
' SORT Macro
'
'
Range("A24:A252").Select
ActiveWorkbook.Worksheets("Totals").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Totals").Sort.SortFields.Add Key:=Range("A24:A42") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Totals").Sort
.SetRange Range("A24:A42")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

 

[Weaver]

the best way is to start from the bottom of the sheet to find out the last row with data

lr=cells(rows.count, lIn).end(xlup).row

then instead of the do .. loop, use for..next between your start row and row lr

HTH

 

[mdos1]

Thanks Weaver, I understand the theory a bit but putting into practice....I only get to look at macros once in blue moon. where do i insert this, and what do I take out?

Mark

 

[AlphaFrog]

This uses the .AdvancedFilter method to filter for unique values and copies the filtered results to the other sheet.

<font face=Courier New><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> CommandButton1_Click()<br><br>    <SPAN style="color:#00007F">Dim</SPAN> sIn     <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> sOut    <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> Lastrow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#007F00">'set the two worksheets</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> sIn = Sheets("Valve Schedule")<br>    <SPAN style="color:#00007F">Set</SPAN> sOut = Sheets("Totals")<br><br>    <SPAN style="color:#007F00">'clear ouput range</SPAN><br>    sOut.Range("A24").Resize(1000).ClearContents<br><br>    <SPAN style="color:#007F00">' Filter for Uniques</SPAN><br>    Lastrow = sIn.Range("G" & Rows.Count).End(xlUp).Row<br>    sIn.Range("G6:G" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=<SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#007F00">' Copy filtered uniques</SPAN><br>    sIn.Range("G7:G" & Lastrow).SpecialCells(xlCellTypeVisible).Copy _<br>        Destination:=sOut.Range("A24")<br>    <SPAN style="color:#007F00">' Clear filter</SPAN><br>    <SPAN style="color:#00007F">If</SPAN> sIn.FilterMode <SPAN style="color:#00007F">Then</SPAN> sIn.ShowAllData<br>    <br>    Lastrow = sOut.Range("A" & Rows.Count).End(xlUp).Row<br>    MsgBox "Completed processing. Unique items written: " & Lastrow - 23<br><br>    <SPAN style="color:#007F00">' SORT</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> sOut.Range("A24:A" & Lastrow)<br>        .Sort Key1:=sOut.Range("A24"), Order1:=xlAscending, Header:=xlGuess, _<br>        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _<br>        DataOption1:=xlSortNormal<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[mdos1]

AlphaFrog, thats great many thanks!!

Mark