Solved

upgrading code for excel worksheet routine to find values ALSO in another Column if not found in first column

Posted on 2014-07-30
7
131 Views
Last Modified: 2014-07-31
For Reference:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28244490.html

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.


What I need:   I need to also search in Column "F" for the value from Column A.
BUT ONLY IF THE VALUE IS NOT FOUND IN Column A

Sub EB_QMatch()
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
' we got no error and can end this
     MsgBox "Data Ready For Review", vbInformation, "EB_Conversion"

    displayData
    FILTERSET
End Sub
      
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
                Rows(xOut_Row).Font.Bold = True
                
             End If
            Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value 'copy B:T 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


Thanks
fordraiders
0
Comment
Question by:fordraiders
  • 4
  • 3
7 Comments
 
LVL 10

Accepted Solution

by:
FamousMortimer earned 500 total points
ID: 40229945
Hi,

Will this work for you?

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 xFind Is Nothing Then
            Set xFind = xSheet.Range("F:F").Find(what:=xSKU, AFTER:=xLast, LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows _
                        , searchdirection:=xlNext, MatchCase:=False)
        End If
        
        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
                    Rows(xOut_Row).Font.Bold = True
                    
                 End If
                Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value 'copy B:T values
                
                xFirst = False
                Set xLast = xFind
                xOut_Row = xOut_Row + 1
                
                Debug.Print " - " & xFind.Row & " - " & xOut_Row
            End If
        Else
            
        End If
    
    Loop Until xFind Is Nothing
    
    Find_Match = xOut_Row

End Function

Open in new window

0
 
LVL 3

Author Comment

by:fordraiders
ID: 40230151
Set xLast = xSheet.Range("A" & xLast_Row + 1)   <------

will this need to be changed also ?
0
 
LVL 3

Author Comment

by:fordraiders
ID: 40230163
and then this part adjusted also ?
Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value 'copy B:T values
to maybe
Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, -5).Resize(1, 20).Value 'copy B:T values

??
\
Thanks
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 10

Expert Comment

by:FamousMortimer
ID: 40230453
To your first question, it should be ok as it's unless you have a different number of rows in each column. Good catch on the second one. I missed that.
0
 
LVL 3

Author Comment

by:fordraiders
ID: 40230983
added a couple boolean variables to define the difference in the search columns.

Do


xsSku = True
xMfr = False
Set xLast = xSheet.Range("A" & xLast_Row + 1)
    Set xFind = xSheet.Range("A:A").Find(what:=xSku, AFTER:=xLast, LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows _
            , searchdirection:=xlNext, MatchCase:=False)
           
           
            If xFind Is Nothing Then
           xsSku = False
           xMfr = True
            Set xLast = xSheet.Range("F" & xLast_Row + 1)
            Set xFind = xSheet.Range("F:F").Find(what:=xSku, AFTER:=xLast, LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows _
                        , searchdirection:=xlNext, MatchCase:=False)
        End If
   
    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
                Rows(xOut_Row).Font.Bold = True
               
             End If
             
            If xsSku = True Then
               Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, 0).Resize(1, 20).Value 'copy B:T values
            Else
                  Range("A" & xOut_Row & ":T" & xOut_Row) = xFind.Offset(0, -5).Resize(1, 20).Value 'copy B:T values
            End If
           
           
           
            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
0
 
LVL 3

Author Closing Comment

by:fordraiders
ID: 40230984
Thanks for the lead in.
0
 
LVL 10

Expert Comment

by:FamousMortimer
ID: 40231535
Good Job, and thanks for the grade.
0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now