upgrading code for excel worksheet routine to find values on other sheets

excel 2010 vba

I have a workbook with 3 sheets
Sheet "Main" in Column A, i place numeric and alphanumeric.  Sometimes 30 values.
Sometimes 100 to 300 values.

After i place the value in Column A on the "Main" sheet I press a button and the values are looped one by one from Sheet main and if it finds a match on sheets3 and/or 4 it places data to the right of the requested number.

If it finds multiple matches additional matches are inserted underneath the requested number.

Dim i          As Long
Dim xLast_Row1 As Long
Dim xLast_Row2 As Long
Dim xLast_Row3 As Long
Dim xOut_Row   As Long
Dim xSKU       As Variant
Dim xMain      As Worksheet
Dim xSearch2   As Worksheet
Dim xSearch3   As Worksheet

Set xMain = Worksheets("Main")
Set xSearch2 = Worksheets("Sheet3")
Set xSearch3 = Worksheets("Sheet4")

xLast_Row1 = xMain.UsedRange.Cells(1, 1).Row + xMain.UsedRange.Rows.Count - 1
xLast_Row2 = xSearch2.UsedRange.Cells(1, 1).Row + xSearch2.UsedRange.Rows.Count - 1
xLast_Row3 = xSearch3.UsedRange.Cells(1, 1).Row + xSearch3.UsedRange.Rows.Count - 1

xMain.Activate

If xLast_Row1 < 2 Then
    MsgBox ("No data found in " & xMain.Name & " - run cancelled.")
    Exit Sub
End If

Range("B2:T" & xLast_Row1).ClearContents

Application.ScreenUpdating = True
    For i = xLast_Row1 To 2 Step -1
    
        Debug.Print i
        
        xSKU = Range("A" & i)
        
        If xSKU <> "" Then

            xOut_Row = i
            If xLast_Row2 > 1 Then xOut_Row = Find_Match(xSearch2, xSKU, xOut_Row, i, xLast_Row2)
            If xLast_Row3 > 1 Then xOut_Row = Find_Match(xSearch3, xSKU, xOut_Row, i, xLast_Row3)
            
        Else
            
            Rows(i).Delete Shift:=xlUp
        
        End If
        
    Next

Application.ScreenUpdating = True

Open in new window




I'm looking to see if any imporvements on the code can be made without going to access.

Thanks
fordraiders
LVL 3
FordraidersAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
I don't know why you do xMain.UsedRange.Cells(1, 1).Row + xMain.UsedRange.Rows.Count - 1 (and similarly for lines 16 and 17. I believe xMain.UsedRange.Cells(1, 1).Row will always be equal to 1 so why not just do the normal xMain.UsedRange.Rows.Count ?

Also you check for the absence of data on Sheet3. Should you also be doing it for sheet4?

Are there any specific problems you are trying to correct?
0
FordraidersAuthor Commented:
so why not just do the normal xMain.UsedRange.Rows.Count ?

flow over code, I inherited it.

Also you check for the absence of data on Sheet3. Should you also be doing it for sheet4?

yes..


just getting it faster...it really slows down after getting past requesting 50 records.

Thanks
0
Martin LissOlder than dirtCommented:
With Long data types you should not get overflow errors. Where they ever Integer?

How many records do you have?
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

FordraidersAuthor Commented:
IN EACH SHEET:  300,000 ROWS.
0
Martin LissOlder than dirtCommented:
Okay, there are perhaps a few things you can do. but that is a lot of records. Can you post a sample workbook that I can test with. Also what kind of run time would you consider acceptable?
0
broro183Commented:
hi,

Martin, up until very recently (see comments in this thread) I thought the same as you regarding usedrange.rows.count. However, if rows 1:2 of a spreadsheet are empty and rows 3:5 are populated then usedrange.rows.count = 3 and checking usedrange.address shows what is going on.

Here is some slightly modified code, but from what I can see, there could be much more to gain from modifying the "Find_Match" Function. Can you please upload the code for the "Find_Match" function?

Option Explicit
Sub SearchAndMove()

Const FirstInputRow As Long = 2
Dim i As Long
Dim xLast_Row1 As Long
Dim xLast_Row2 As Long
Dim xLast_Row3 As Long
'Dim xOut_Row As Long
Dim xSKU As Variant
Dim xMain As Worksheet
Dim xSearch2 As Worksheet
Dim xSearch3 As Worksheet
Dim ItemsToFindArr As Variant    'in memory array for speed

    Set xMain = Worksheets("Main")
    Set xSearch2 = Worksheets("Sheet3")
    Set xSearch3 = Worksheets("Sheet4")

    With xMain.UsedRange
        xLast_Row1 = .Cells(1, 1).Row + .Rows.Count - 1
    End With
    With xSearch2.UsedRange
        xLast_Row2 = .Cells(1, 1).Row + .Rows.Count - 1
    End With
    With xSearch3.UsedRange
        xLast_Row3 = .Cells(1, 1).Row + .Rows.Count - 1
    End With

    If xLast_Row1 < FirstInputRow Then
        MsgBox ("No data found in " & xMain.Name & " - run cancelled.")
        Exit Sub
    End If

    Application.ScreenUpdating = False
    With xMain
        .Range("B" & FirstInputRow & ":T" & xLast_Row1).ClearContents
        ItemsToFindArr = .Range("A" & FirstInputRow & ":A" & xLast_Row1).Value

        '        For i = xLast_Row1 To FirstInputRow Step -1
        For i = UBound(ItemsToFindArr) To LBound(ItemsToFindArr) Step -1
            Debug.Print i
            'xSKU = .Range("A" & i)
            xSKU = ItemsToFindArr(i, 1)
            If xSKU <> vbNullString Then
                '                xOut_Row = i
                '                If xLast_Row2 > 1 Then xOut_Row = Find_Match(xSearch2, xSKU, xOut_Row, i, xLast_Row2)
                '                If xLast_Row3 > 1 Then xOut_Row = Find_Match(xSearch3, xSKU, xOut_Row, i, xLast_Row3)
                '"Find_Match" appears to be a function but the result "xOut_Row" is not used anywhere
                '(other than when it is over-written by "xOut_Row = i"). Can "Find_Match" be changed into a sub
                'so the above lines can be re-written as shown below?
                If xLast_Row2 > 1 Then Find_Match xSearch2, xSKU, i, i, xLast_Row2
                If xLast_Row3 > 1 Then Find_Match xSearch3, xSKU, i, i, xLast_Row3
            Else
                .Rows(i + FirstInputRow - 1).Delete Shift:=xlUp
            End If
        Next i
    End With

    Set xMain = nothing
    Set xSearch2 = nothing
    Set xSearch3 = nothing

    Application.ScreenUpdating = True

End Sub

Sub Find_Match(xSearchBlah, xSKUBlah, iBlah1, iBlah2, xLast_RowBlah)
'what does this do?
End Sub

Open in new window


hth
Rob
0
FordraidersAuthor Commented:
ok sorry thought i had it copied.
Function Find_Match(xSheet As Worksheet, xSKU As Variant, ByVal xOut_Row As Long, xMaster_Row As Long, xLast_Row As Long)
Dim xFind As Range
Dim xLast As Range
Dim xFirst As Boolean

xFirst = True
Set xLast = xSheet.Range("A" & xLast_Row + 1)

Do

    Set xFind = xSheet.Range("A:A").Find(what:=xSKU, AFTER:=xLast, LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows _
            , searchdirection:=xlNext, MatchCase:=False)
            
    If Not xFind Is Nothing Then
        
        If Not xFirst And xFind.Row <= xLast.Row Then
            Set xFind = Nothing         ' We've looped around.
        Else
            Debug.Print "+++ " & xFind.Address
            If xOut_Row <> xMaster_Row Then
                Rows(xOut_Row).Insert Shift:=xlDown
                  ' BOLD ROW FOR DUPLICATE MFRNUMBERS
                Rows(xOut_Row).Font.Bold = True
              '  Rows(xOut_Row).Font.ColorIndex = 3 'Bold = True
                
             End If
            Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value 'copy B:W values
            
            xFirst = False
            Set xLast = xFind
            xOut_Row = xOut_Row + 1
            
            Debug.Print " - " & xFind.Row & " - " & xOut_Row
        End If
        
    End If

Loop Until xFind Is Nothing

Find_Match = xOut_Row

End Function

Open in new window

0
Martin LissOlder than dirtCommented:
Deleting rows one by one and moving the rest up the data up is very slow even if you have Application.ScreenUpdating = False. There are a couple of ways that are much faster but I'd need at least a sample workbook to add the code.
0
FordraidersAuthor Commented:
ok...is there a way to send it secured?
0
Martin LissOlder than dirtCommented:
I don't think there is but couldn't you make a copy of the workbook and remove all but a couple of dozen rows in each of the sheets and change the sensitive data in the remaining rows?
0
FordraidersAuthor Commented:
perfect ...Thanks
here you go
EEMartinlessv6.xlsm
0
Martin LissOlder than dirtCommented:
I looked in the workbook for SearchAndMove but couldn't find it. The closest I could find was EB_Quik_Match so I'll assume that that's the sub you want me to change.
0
Martin LissOlder than dirtCommented:
I'm a little confused about what EB_Quik_Match and Find_Match are trying to do. I mean I understand the code but can you describe the purpose? And while I said I understand the code can you tell me why you define and calculate xOut_Row in EB_Quik_Match but you never use the value?
0
FordraidersAuthor Commented:
yes and findmatch
0
Martin LissOlder than dirtCommented:
I'm sorry but now that I understand the process better I realize that I can't help. Sorry to have wasted your time.
0
broro183Commented:
hi,

I don't understand the process well enough yet. To help me:
- Why are there two sheets to search against?
- Can these sheets be combined into a single sheet (perhaps with an extra column that identifies if it relates to "sheet 3" or "sheet 4")?
- Does it matter if sheet 3 & sheet 4 are sorted by the SKU column?
If not, then hold the Input SKU list as an in memory array, sort the sheets, use autofilter to filter for each element of the array, copy it to the Main sheet, & repeat for each element of the array.
- Is the Input SKU a unique identifier (ie if it appears on both sheet 3 & sheet 4, is the data in columns B:T going to be exactly the same on each sheet or for multiple occurrences on each sheet)?
- If so, I would tend towards an Index/Match or Vlookup approach.

I may not get back to this for another day or so, but I've included some ideas which may get you started.

On a separate note, lookup "copyfromrecordset" which may help speed up your recordset code instead of populating values into individual cells.

hth
Rob
0
FordraidersAuthor Commented:
Rob
Why are there two sheets to search against?
i may have up to 300,000 rows on each sheet.

Does it matter if sheet 3 & sheet 4 are sorted by the SKU column?
no, but yes if it helps.

Is the Input SKU a unique identifier (ie if it appears on both sheet 3 & sheet 4, is the data in columns B:T going to be exactly the same on each sheet or for multiple occurrences on each sheet)?

the data from b:t will be placed on sheet "main" from sheet3 and sheet4
and repeated if found more than once. some pieces of the data from b:t may be different.
thats why they need to be repeated.

go to "main"   type in a value from Column A from sheet3 or 4
and hit the button.
The data if found will  be posted on sheet "Main"
0
Martin LissOlder than dirtCommented:
I did think of another way to get the data that my be faster. Replace your Find_Match function with this. You will also need to change xSKU to String in EB_Quik_Match.


Function Find_Match(xSheet As Worksheet, xSKU As String, ByVal xOut_Row As Long, xMaster_Row As Long, xLast_Row As Long)

Dim lngCount As Long
Dim rngToCheck As Range
With xSheet
    Set rngToCheck = .Range(.Cells(2, 1), .Cells(xLast_Row, 1))
End With
'Set xLast = xSheet.Range("A" & xLast_Row + 1)
lngCount = WorksheetFunction.CountIf(xSheet.Range("A:A"), xSKU)

Application.ScreenUpdating = False

With rngToCheck
    .AutoFilter Field:=1, Criteria1:=xSKU
    lngCount = .SpecialCells(xlCellTypeVisible).Count
    If lngCount > 1 Then
        For xOut_Row = xOut_Row To xOut_Row + lngCount - 2
        If xOut_Row <> xMaster_Row Then
            Rows(xOut_Row).Insert Shift:=xlDown
            ' BOLD ROW FOR DUPLICATE MFRNUMBERS
            Rows(xOut_Row).Font.Bold = True
            End If
            Range("A" & xOut_Row & ":T" & xOut_Row) = .Rows(xOut_Row).Offset(0, 0).Resize(1, 20).Value
        Next
    End If
    .AutoFilter
End With

Application.ScreenUpdating = True

End Function

Open in new window

0
broro183Commented:
hi,

The following code isn't optimised yet, but does it do what you want?
If it does, I'll move re arrange the code to prevent the repetition of the same actions.

Option Explicit
Const FirstInputRow As Long = 2

Sub SearchAndMove_v2()

Dim xLast_Row1 As Long
Dim xSKU As String
Dim xMain As Worksheet
Dim xSearch2 As Worksheet
Dim xSearch3 As Worksheet
Dim ItemsToFindArr As Variant    'in memory array for speed
Dim ArrInd As Long    'array index (loop counter)

    With ThisWorkbook
        Set xMain = .Worksheets("Main")
        Set xSearch2 = .Worksheets("Sheet3")
        Set xSearch3 = .Worksheets("Sheet4")
    End With

    With xMain.UsedRange
        xLast_Row1 = .Cells(1, 1).Row + .Rows.Count - 1
    End With

    If xLast_Row1 < FirstInputRow Then
        MsgBox ("No data found in " & xMain.Name & " - run cancelled.")
        Exit Sub
    End If

    Application.ScreenUpdating = False
    With xMain
        '        .Range("B" & FirstInputRow & ":T" & xLast_Row1).ClearContents
        ItemsToFindArr = .Range("A" & FirstInputRow & ":A" & xLast_Row1).Value
''        .Rows(FirstInputRow & ":" & xLast_Row1).Delete

        For ArrInd = LBound(ItemsToFindArr) To UBound(ItemsToFindArr) Step 1
            xSKU = ItemsToFindArr(ArrInd, 1)
            Debug.Print xSKU
            If xSKU <> vbNullString Then
                Call Find_Match_v2(xMain, xSearch2, xSKU)
                Call Find_Match_v2(xMain, xSearch3, xSKU)
            End If
        Next ArrInd
    End With
    Application.ScreenUpdating = True
MsgBox "Done"
    Set xMain = Nothing
    Set xSearch2 = Nothing
    Set xSearch3 = Nothing

End Sub

Sub Find_Match_v2(PasteWs As Worksheet, SearchWs As Worksheet, xSKU As String)   ', ByVal xOut_Row As Long, xMaster_Row As Long, xLast_Row As Long)
Const FieldToFilter As Long = 1    'column A
Dim xFind As Range
    'Dim xLast As Range
Dim AutoFilterRng As Range
Dim AfDataOnlyRng As Range
Dim PasteCll As Range

    With PasteWs
        Set PasteCll = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
    End With

    With SearchWs
        Select Case .AutoFilterMode
            Case True
                Set AutoFilterRng = .AutoFilter.Range
                .AutoFilter.ShowAllData
            Case False
                'adds an autofilter
                Set AutoFilterRng = .Range(.Cells(1, 1), LastCell(SearchWs))
                With .AutoFilter
                    .Range = AutoFilterRng
                    With .Sort
                        With .SortFields
                            .Clear
                            Stop
                            .Add Key:=AutoFilterRng.Columns(, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                                 xlSortTextAsNumbers
                        End With
                        .Header = xlYes
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
                End With
        End Select
    End With
    With AutoFilterRng
        .AutoFilter Field:=FieldToFilter, Criteria1:="=" & xSKU
        Set AfDataOnlyRng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
    Debug.Print AfDataOnlyRng.Address
    End With

On Error Resume Next
Set xFind = AfDataOnlyRng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

    If Not xFind Is Nothing Then
Stop
        With xFind
            .Copy PasteCll
            '' BOLD ROW FOR DUPLICATE MFRNUMBERS
            PasteCll.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Font.Bold = True
            '  Rows(xOut_Row).Font.ColorIndex = 3 'Bold = True
            '    Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value    'copy B:W values
        End With
    End If
    AutoFilterRng.AutoFilter Field:=FieldToFilter


    Set xFind = Nothing
    Set PasteCll = Nothing
End Sub

Function LastCell(ws As Worksheet) As Range
'This is Broro183's AttemptAtARobustLastCellFinder_v4 sourced from http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39474286
'inspired by FP's comments about a "binary chop" approach http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380467
'still subject to the limitations of CountA which Qlemo mentioned: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380520

Dim PercentArr As Variant    'this can probably be written better
Dim PercentageMultiplier As Double
Dim PercentInd As Long    'percent loop index
Dim LastRow As Long
Dim LastCol As Long
Dim RowsInWs As Long
Dim ColsInWs As Long
Dim LoopInd As Long
Dim UpperLim As Long
Dim BlockSizer As Long
Dim FirstRowOfUsedRng As Long

    With ws
        RowsInWs = .Rows.Count
        ColsInWs = .Columns.Count
    End With
    PercentArr = Array(0.5, 0.3, 0.1, 0.05, 0.03, 0.01, 0.005, 0.003, 0.001, 1)

    'run a loop to find the last row
    'v4, amended in case the first row of the used range is not Row 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(RowsInWs, .Cells(1, 1).Row - 1 + .Rows.Count)
    End With

    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * RowsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                If Application.CountA(ws.Range(LoopInd - BlockSizer + 1 & ":" & LoopInd)) Then
                    Exit For
                End If
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastRow = Application.WorksheetFunction.Max(1, UpperLim)

    'run a loop to find the last column
    'v4, amended in case the first column of the used range is not column 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(ColsInWs, .Cells(1, 1).Column - 1 + .Columns.Count)
    End With
    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * ColsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                With ws
                    'Searches entire columns
                    'v4 corrected as per http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39392583
                    If Application.CountA(.Range(.Cells(1, LoopInd - BlockSizer + 1), .Cells(RowsInWs, LoopInd))) Then
                        Exit For
                    End If
                End With
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastCol = Application.WorksheetFunction.Max(1, UpperLim)

    '    'User feedback for testing
    '    Debug.Print "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address
    '    MsgBox "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address

    Set LastCell = ws.Cells(LastRow, LastCol)

End Function

Open in new window


hth
Rob
0
FordraidersAuthor Commented:
rob,

object variable or with block variable not set on line below:

With SearchWs
        Select Case .AutoFilterMode
            Case True
                Set AutoFilterRng = .AutoFilter.Range
                .AutoFilter.ShowAllData
            Case False
                'adds an autofilter
                Set AutoFilterRng = .Range(.Cells(1, 1), LastCell(SearchWs))
                With .AutoFilter
                    .Range = AutoFilterRng  '<-----------  error here
                    With .Sort
                        With .SortFields
                            .Clear
                            Stop
                            .Add Key:=AutoFilterRng.Columns(, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                                 xlSortTextAsNumbers
                        End With
                        .Header = xlYes
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
                End With
        End Select
    End With
0
FordraidersAuthor Commented:
martinless:

application defined error on line below:

With rngToCheck
    .AutoFilter Field:=1, Criteria1:=xSKU
    lngCount = .SpecialCells(xlCellTypeVisible).Count
    If lngCount > 1 Then
        For xOut_Row = xOut_Row To xOut_Row + lngCount - 2
        If xOut_Row <> xMaster_Row Then
            Rows(xOut_Row).Insert Shift:=xlDown  < --- application defined error here
            ' BOLD ROW FOR DUPLICATE MFRNUMBERS
            Rows(xOut_Row).Font.Bold = True
            End If
            Range("A" & xOut_Row & ":T" & xOut_Row) = .Rows(xOut_Row).Offset(0, 0).Resize(1, 20).Value
        Next
    End If
    .AutoFilter
End With
0
Martin LissOlder than dirtCommented:
Try this.

Function Find_Matchold(xSheet As Worksheet, xSKU As Variant, ByVal xOut_Row As Long, xMaster_Row As Long, xLast_Row As Long)
Dim xFind As Range
Dim xLast As Range
Dim xFirst As Boolean

xFirst = True
Set xLast = xSheet.Range("A" & xLast_Row + 1)

Do

    Set xFind = xSheet.Range("A:A").Find(what:=xSKU, AFTER:=xLast, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows _
            , SearchDirection:=xlNext, MatchCase:=False)

    If Not xFind Is Nothing Then

        If Not xFirst And xFind.Row <= xLast.Row Then
            Set xFind = Nothing         ' We've looped around.
        Else
            Debug.Print "+++ " & xFind.Address
            With Sheets("Main")
                If xOut_Row <> xMaster_Row Then
                    .Rows(xOut_Row).Insert Shift:=xlDown
                      ' BOLD ROW FOR DUPLICATE MFRNUMBERS
                    .Rows(xOut_Row).Font.Bold = True
                  '  Rows(xOut_Row).Font.ColorIndex = 3 'Bold = True
    
                 End If
                .Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value 'copy B:W values
            End With
            xFirst = False
            Set xLast = xFind
            xOut_Row = xOut_Row + 1

            Debug.Print " - " & xFind.Row & " - " & xOut_Row
        End If

    End If

Loop Until xFind Is Nothing

Find_Matchold = xOut_Row

End Function

Open in new window

0
broro183Commented:
hi,

Sorry, when I looked at my last offering after you mentioned the error, I realised that there were a number of errors in it. I have re-written that macro & have made some small modifications in other macros which is why I am uploading the whole lot again. Please note that the code can be run from the TimerMacro during testing to help us identify the fastest approach.

I'm also going to test a different approach which is going to be based on:
- adding a helper column to the search sheets
- putting in a Match formula to see what rows are listed on the Match sheet
- changing the helper column from formulae to values
- sorting the sheet by the helper column & the SKU
- filtering the helper column to exclude N/A's
- copying & pasting a single block for each sheet.
If I think it has any merit, ie speed, I'll add it to this thread over the next fortnight.

Option Explicit
Const FirstInputRow As Long = 2
Const FieldToFilter As Long = 1    'column A
Public glb_origCalculationMode As Long
Public glb_origStatusBar As String


Sub TimerMacro()
Dim StartTime As Double
Dim EndTime As Double

    StartTime = Now
    Call SearchAndMove_v3
    'Call EB_Quik_Match_v1
    EndTime = Now

    Debug.Print "Done in " & Format(EndTime - StartTime, "hh:mm:ss") & ". Started at " & Format(StartTime, "hh:mm:ss") & " and finished at " & Format(EndTime, "hh:mm:ss") & "."
    MsgBox "Done in " & Format(EndTime - StartTime, "hh:mm:ss") & ". Started at " & Format(StartTime, "hh:mm:ss") & " and finished at " & Format(EndTime, "hh:mm:ss") & "."

End Sub



Sub RefreshXlApp()
    With Application
        .EnableEvents = True
        On Error Resume Next
        .Calculation = xlCalculationAutomatic
        On Error GoTo 0
        .StatusBar = False
        .ScreenUpdating = True
        .DisplayFormulaBar = True
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
    End With
End Sub
Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Sub SearchAndMove_v3()

Dim xLast_Row1 As Long
Dim xSKU As String
Dim xMain As Worksheet
Dim xSearch2 As Worksheet
Dim xSearch3 As Worksheet
Dim ItemsToFindArr As Variant    'in memory array for speed
Dim ArrInd As Long    'array index (loop counter)
Dim ws As Worksheet

    With ThisWorkbook
        Set xMain = .Worksheets("Main")
        Set xSearch2 = .Worksheets("Sheet3")
        Set xSearch3 = .Worksheets("Sheet4")
    End With

    With xMain
        With .UsedRange
            xLast_Row1 = .Cells(1, 1).Row + .Rows.Count - 1
        End With

        If xLast_Row1 < FirstInputRow Then
            MsgBox ("No data found in " & .Name & " - run cancelled.")
            Exit Sub
        End If

        Call ToggleRefreshXlApp(False)
        ItemsToFindArr = .Range("A" & FirstInputRow & ":A" & xLast_Row1).Value
        .Rows(FirstInputRow & ":" & xLast_Row1).Delete
    End With

    For Each ws In ThisWorkbook.Sheets(Array(xSearch2.Name, xSearch3.Name))
        Call SetUpAutoFilterAndSortSearchWS_v3(ws)
    Next ws

    For ArrInd = LBound(ItemsToFindArr) To UBound(ItemsToFindArr) Step 1
        xSKU = ItemsToFindArr(ArrInd, 1)
        '        Debug.Print "xSKU: " & xSKU
        If xSKU <> vbNullString Then
            For Each ws In ThisWorkbook.Sheets(Array(xSearch2.Name, xSearch3.Name))
                With ws
                    'initial existence check to minimise amount of autofiltering
                    '                    If Application.WorksheetFunction.CountIf(.Range(.Cells(FirstInputRow, FieldToFilter), .Cells(LastCell(ws).Row, FieldToFilter)), xSKU) Then
                    If IsNumeric(Application.Match(xSKU, .Range(.Cells(FirstInputRow, FieldToFilter), .Cells(LastCell(ws).Row, FieldToFilter)), 0)) Then
                        Call Find_Match_v3(xMain, ws, xSKU)
                    Else
                        '                        '### Optional, to maintain the original list.
                        '                        With xMain
                        '                            With .Range("A" & .Rows.Count).End(xlUp)
                        '                                If .Value2 <> xSKU Then
                        '                                    .Offset(1, 0).Value2 = xSKU
                        '                                End If
                        '                            End With
                        '                        End With
                    End If
                End With
            Next ws
        End If
    Next ArrInd

    Call ToggleRefreshXlApp(True)

    Set xMain = Nothing
    Set xSearch2 = Nothing
    Set xSearch3 = Nothing

End Sub

Sub SetUpAutoFilterAndSortSearchWS_v3(ws As Worksheet)
Dim AutoFilterRng As Range
Dim AfDataOnlyRng As Range

    With ws
        Select Case .AutoFilterMode
            Case True
                'autofilter already exists therefore clear any active filtering
                With .AutoFilter
                    Set AutoFilterRng = .Range
                    .ShowAllData
                End With
            Case False
                'adds an autofilter
                Set AutoFilterRng = .Range(.Cells(1, 1), LastCell(ws))
                AutoFilterRng.AutoFilter
        End Select

        'sort the data to ensure that if any rows are visible, when the autofilter is applied
        ', that they will be a single contiguous range.
        With .AutoFilter.Sort
            With .SortFields
                .Clear
                .Add Key:=AutoFilterRng.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                     xlSortTextAsNumbers
            End With
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

End Sub

Sub Find_Match_v3(PasteWs As Worksheet, SearchWs As Worksheet, xSKU As String)
Dim xFind As Range
Dim AutoFilterRng As Range
Dim AfDataOnlyRng As Range
Dim PasteCll As Range

    With PasteWs
        Set PasteCll = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
        '        Debug.Print "PasteCll:" & .Name & "!" & PasteCll.Address
    End With

    Set AutoFilterRng = SearchWs.AutoFilter.Range

    With AutoFilterRng
        .AutoFilter Field:=FieldToFilter, Criteria1:="=" & xSKU
        Set AfDataOnlyRng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
    End With
    '    Debug.Print "AfDataOnlyRng.Address: " & SearchWs.Name & "!" & AfDataOnlyRng.Address

    On Error Resume Next
    Set xFind = AfDataOnlyRng.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not xFind Is Nothing Then
        With xFind
            .Copy PasteCll
            If xFind.Rows.Count > 1 Then
                '' BOLD ROW FOR DUPLICATE MFRNUMBERS
                PasteCll.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Font.Bold = True
            End If
        End With
    End If
    AutoFilterRng.AutoFilter Field:=FieldToFilter


    Set xFind = Nothing
    Set PasteCll = Nothing
    Set AfDataOnlyRng = Nothing
    Set AutoFilterRng = Nothing
End Sub

Function LastCell(ws As Worksheet) As Range
'This is Broro183's AttemptAtARobustLastCellFinder_v4 sourced from http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39474286
'inspired by FP's comments about a "binary chop" approach http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380467
'still subject to the limitations of CountA which Qlemo mentioned: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380520

Dim PercentArr As Variant    'this can probably be written better
Dim PercentageMultiplier As Double
Dim PercentInd As Long    'percent loop index
Dim LastRow As Long
Dim LastCol As Long
Dim RowsInWs As Long
Dim ColsInWs As Long
Dim LoopInd As Long
Dim UpperLim As Long
Dim BlockSizer As Long
Dim FirstRowOfUsedRng As Long

    With ws
        RowsInWs = .Rows.Count
        ColsInWs = .Columns.Count
    End With
    PercentArr = Array(0.5, 0.3, 0.1, 0.05, 0.03, 0.01, 0.005, 0.003, 0.001, 1)

    'run a loop to find the last row
    'v4, amended in case the first row of the used range is not Row 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(RowsInWs, .Cells(1, 1).Row - 1 + .Rows.Count)
    End With

    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * RowsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                If Application.CountA(ws.Range(LoopInd - BlockSizer + 1 & ":" & LoopInd)) Then
                    Exit For
                End If
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastRow = Application.WorksheetFunction.Max(1, UpperLim)

    'run a loop to find the last column
    'v4, amended in case the first column of the used range is not column 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(ColsInWs, .Cells(1, 1).Column - 1 + .Columns.Count)
    End With
    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * ColsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                With ws
                    'Searches entire columns
                    'v4 corrected as per http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39392583
                    If Application.CountA(.Range(.Cells(1, LoopInd - BlockSizer + 1), .Cells(RowsInWs, LoopInd))) Then
                        Exit For
                    End If
                End With
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastCol = Application.WorksheetFunction.Max(1, UpperLim)

    '    'User feedback for testing
    '    Debug.Print "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address
    '    MsgBox "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address

    Set LastCell = ws.Cells(LastRow, LastCol)
End Function

Open in new window


hth
Rob
0
broro183Commented:
I forgot to mention that my above code will only return the SKU's from the original input list which are found on the other sheets. If there are no matches the original value is not shown in the Main sheet. There is a commented out "###" section which can be used if you want the original list to the data is maintained.
0
Martin LissOlder than dirtCommented:
Did any of our suggestions help you?
0
FordraidersAuthor Commented:
martinless, your suggestions did run , but ran in the same amount of time.
0
broro183Commented:
hi FordRaiders,

Did my last lot of code work for you?

I think that the below code is the fastest that I can make it. It has the same feature as my last offering, wrt the fact that it removes any SKU's from the Main sheet that don't have matches on the other two sheets. If you do need the original list to be kept, let me know & I'll see if I can add it back in without affecting the execution time too much.

To test the code run the TimerMacro which includes a ToggleRefreshXlApp "wrapper" that toggles the application settings. This wrapper & some of the other "extra" code may help with the speed.

Option Explicit

Const HdrRow As Long = 1
Const FirstInputRow As Long = 2
Const SKUFieldToFilter As Long = 1    'column A
Public glb_origCalculationMode As Long
Public glb_origStatusBar As String

Sub TimerMacro()
Dim StartTime As Double
Dim EndTime As Double

    Call ToggleRefreshXlApp(False)
    StartTime = Now
    'Call EB_Quik_Match_v1
    'Call SearchAndMove_v3
    Call MatchFilterAndCopyIntoMainWs
    EndTime = Now
    Call ToggleRefreshXlApp(True)

    Debug.Print "Done in " & Format(EndTime - StartTime, "hh:mm:ss") & ". Started at " & Format(StartTime, "hh:mm:ss") & " and finished at " & Format(EndTime, "hh:mm:ss") & "."
    MsgBox "Done in " & Format(EndTime - StartTime, "hh:mm:ss") & ". Started at " & Format(StartTime, "hh:mm:ss") & " and finished at " & Format(EndTime, "hh:mm:ss") & "."
End Sub

Sub MatchFilterAndCopyIntoMainWs()
Dim SearchWs As Worksheet
Dim xMain As Worksheet
Dim xSearch2 As Worksheet
Dim xSearch3 As Worksheet
Dim AfRng As Range    'Autofilter range (includes headers)
Dim AfDataOnlyRng As Range    'Autofilter data range (excludes headers)
Dim xFind As Range
Dim PasteCll As Range
Dim SearchWsLCell As Range
Dim SearchWsLRow As Long
Dim SearchWsLCol As Long
Dim MatchEqtn As String
Dim OriInputCells As Range

    With ThisWorkbook
        Set xMain = .Worksheets("Main")
        Set xSearch2 = .Worksheets("Sheet3")
        Set xSearch3 = .Worksheets("Sheet4")
    End With

    With xMain
        Set OriInputCells = .Range(.Cells(FirstInputRow, 1), .Cells(LastCell(xMain).Row, 1))
    End With
    With OriInputCells
        .EntireRow.Font.Bold = False
        MatchEqtn = "=MATCH(RC1,'" & xMain.Name & "'!" & .Address(, , xlR1C1) & ",0)"
    End With

    For Each SearchWs In ThisWorkbook.Sheets(Array(xSearch2.Name, xSearch3.Name))

        Set SearchWsLCell = LastCell(SearchWs)
        With SearchWsLCell
            SearchWsLRow = .Row
            SearchWsLCol = .Column
        End With

        With SearchWs
            With .Cells(HdrRow, .Columns.Count).End(xlToLeft).Offset(0, 1)
                .Value2 = "Does SKU exist on Main sheet?"
                With .Offset(1, 0).Resize(SearchWsLRow - FirstInputRow + 1, 1)
                    .NumberFormat = "General"
                    .FormulaR1C1 = MatchEqtn
                    .Calculate
                    .Value2 = .Value2
                End With
                Set SearchWsLCell = SearchWsLCell.Offset(0, 1)
                SearchWsLCol = SearchWsLCol + 1
            End With

            Call SetUpAutoFilterAndSortWs_v3(SearchWs, SearchWsLCol, True)
            Set AfRng = .Range(.Cells(HdrRow, 1), SearchWsLCell)
        End With

        With AfRng
            Set AfDataOnlyRng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
            'Debug.Print "AfDataOnlyRng.Address: " & SearchWs.Name & "!" & AfDataOnlyRng.Address
            .AutoFilter Field:=SearchWsLCol, Criteria1:="<>#N/A"
        End With

        On Error Resume Next
        Set xFind = AfDataOnlyRng.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not xFind Is Nothing Then
            With xMain
                Set PasteCll = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            With xFind
                PasteCll.Resize(.Rows.Count, .Columns.Count).Value2 = .Value2
            End With
        End If

        ''The next lines are optional.
        'The first line clears the selected filter and leaves the additional column.
        'The second line deletes the additional column with the result that the data becomes unfiltered.
        'AfRng.AutoFilter Field:=SearchWsLCol
        SearchWs.Columns(SearchWsLCol).Delete

    Next SearchWs

    OriInputCells.EntireRow.Delete
    With xMain
        .Columns(SearchWsLCol).Delete

        '        If .Rows.Count > 1 Then
        '            '' BOLD ROW FOR DUPLICATE MFRNUMBERS
        '            PasteCll.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Font.Bold = True
        '        End If
        Call SetUpAutoFilterAndSortWs_v3(xMain, SKUFieldToFilter, False)
        Call IdAndBoldDupRows(xMain)

    End With

    Set OriInputCells = Nothing
    Set AfDataOnlyRng = Nothing
    Set AfRng = Nothing
    Set xFind = Nothing
    Set PasteCll = Nothing
    Set SearchWsLCell = Nothing
    Set xMain = Nothing
    Set xSearch2 = Nothing
    Set xSearch3 = Nothing
End Sub

Sub IdAndBoldDupRows(ws As Worksheet)
Dim OutputSkuArr As Variant
Dim OuterInd As Long
Dim InnerInd As Long
Dim CurSku As String

    With ws
        OutputSkuArr = .Range(.Cells(FirstInputRow, 1), .Cells(FirstInputRow, 1).End(xlDown))
    End With

    For OuterInd = LBound(OutputSkuArr) To UBound(OutputSkuArr)
        CurSku = OutputSkuArr(OuterInd, 1)
        InnerInd = 1
        Do Until CurSku <> OutputSkuArr(OuterInd + InnerInd, 1)
            InnerInd = InnerInd + 1
            If OuterInd + InnerInd > UBound(OutputSkuArr) Then Exit Do
        Loop
        If InnerInd > 1 Then
            ws.Range(FirstInputRow + OuterInd & ":" & FirstInputRow - 1 + OuterInd + InnerInd - 1).Font.Bold = True
        End If
        OuterInd = OuterInd + InnerInd - 1
    Next OuterInd
End Sub

Sub SetUpAutoFilterAndSortWs_v3(ws As Worksheet, SortCol As Long, TurnOffExistingAF As Boolean)
Dim AutoFilterRng As Range

    With ws
        If TurnOffExistingAF Then
            .AutoFilterMode = False
        End If
        Select Case .AutoFilterMode
            Case True
                'autofilter already exists therefore clear any active filtering
                With .AutoFilter
                    Set AutoFilterRng = .Range
                    .ShowAllData
                End With
            Case False
                'adds an autofilter
                Set AutoFilterRng = .Range(.Cells(HdrRow, 1), LastCell(ws))
                AutoFilterRng.AutoFilter
        End Select

        'sort the data to ensure that if any rows are visible, when the autofilter is applied
        ', that they will be a single contiguous range.
        With .AutoFilter.Sort
            With .SortFields
                .Clear
                .Add Key:=AutoFilterRng.Columns(SortCol), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                     xlSortTextAsNumbers
            End With
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    Set AutoFilterRng = Nothing
End Sub

Sub RefreshXlApp()
    With Application
        .EnableEvents = True
        On Error Resume Next
        .Calculation = xlCalculationAutomatic
        On Error GoTo 0
        .StatusBar = False
        .ScreenUpdating = True
        .DisplayFormulaBar = True
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
    End With
End Sub

Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Function LastCell(ws As Worksheet) As Range
'This is Broro183's AttemptAtARobustLastCellFinder_v4 sourced from http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39474286
'inspired by FP's comments about a "binary chop" approach http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380467
'still subject to the limitations of CountA which Qlemo mentioned: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380520

Dim PercentArr As Variant    'this can probably be written better
Dim PercentageMultiplier As Double
Dim PercentInd As Long    'percent loop index
Dim LastRow As Long
Dim LastCol As Long
Dim RowsInWs As Long
Dim ColsInWs As Long
Dim LoopInd As Long
Dim UpperLim As Long
Dim BlockSizer As Long

    With ws
        RowsInWs = .Rows.Count
        ColsInWs = .Columns.Count
    End With
    PercentArr = Array(0.5, 0.3, 0.1, 0.05, 0.03, 0.01, 0.005, 0.003, 0.001, 1)

    'run a loop to find the last row
    'v4, amended in case the first row of the used range is not Row 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(RowsInWs, .Cells(1, 1).Row - 1 + .Rows.Count)
    End With

    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * RowsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                If Application.CountA(ws.Range(LoopInd - BlockSizer + 1 & ":" & LoopInd)) Then
                    Exit For
                End If
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastRow = Application.WorksheetFunction.Max(1, UpperLim)

    'run a loop to find the last column
    'v4, amended in case the first column of the used range is not column 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(ColsInWs, .Cells(1, 1).Column - 1 + .Columns.Count)
    End With
    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * ColsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                With ws
                    'Searches entire columns
                    'v4 corrected as per http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39392583
                    If Application.CountA(.Range(.Cells(1, LoopInd - BlockSizer + 1), .Cells(RowsInWs, LoopInd))) Then
                        Exit For
                    End If
                End With
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastCol = Application.WorksheetFunction.Max(1, UpperLim)

    '    'User feedback for testing
    '    Debug.Print "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address
    '    MsgBox "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address

    Set LastCell = ws.Cells(LastRow, LastCol)
End Function

Open in new window


hth
Rob
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FordraidersAuthor Commented:
it did work..but was also at the same speed..

But will try this new post ...

Thanks very much !!

fordraiders
0
FordraidersAuthor Commented:
Thanks...improvement in speed
0
broro183Commented:
hi FordRaiders,

Thank you for the points, I'm pleased I could help.

Please read through the code that both Martin & I have offered and ask questions about anything that you don't understand. This will help your understanding & may save you the need to ask as many questions about optimising excel vba code in the future.

Rob
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.