Offset based on Values in Column E

[mrmmickle1]

I would like to search through Column E and find the value "Open" if there is a hit I want to move 4 cells to the right and input the value "Gate 1" then go to the next "Open" in row E and do the same thing.
I am trying to use this on several different key words so that I can sort them together at a later point in the macro. For example "Open" and "Recieved" = "Gate 1" while "Approved" and "Disassemble" = "Gate 2"
Once I have accomplished this I will be able to sort them and Outline them grouped int the same category. This is what I have so far. I am obviously missing something:

Sub StatusQaulifierForOpenIsGate1()
    IFind = "Open"
    Set rFound = Columns(5).Find(What:=IFind, LookIn:=xlValues, LookAt:= _
        xlPart, MatchCase:=False, SearchFormat:=False)
        If Not rFound Is Nothing Then
            rFound.Activate
            rFound.Offset(0, Target.Column + 4).Value = "Gate 1"
    End If
End Sub

I have tried to add

Next

and

For rfound

into the code but I am unfamiliar with this process can someone please help me out? It would be much appreciated

[Admin]

Hi

Try something like this.

Sub kTest()
    
    Dim i As Long, j As Long, r As Range, ff As String
    Dim SearchKeys1, SearchKeys2, SearchKeysAll, Replacement
    
    SearchKeys1 = Array("Open", "Received")
    SearchKeys2 = Array("Approved", "Disassemble")
    
    SearchKeysAll = Array(SearchKeys1, SearchKeys2)
    
    Replacement = Array("Gate 1", "Gate 2")
    
    With Intersect(ActiveSheet.UsedRange, Columns(5))
        For i = LBound(Replacement) To UBound(Replacement)
            For j = LBound(SearchKeysAll(i)) To UBound(SearchKeysAll(i))
                Set r = .Find(SearchKeysAll(i)(j), lookat:=2)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        Set r = .FindNext(r)
                        r.Offset(, 4) = Replacement(i)
                    Loop Until r.Address = ff
                End If
            Next
        Next
    End With
    
End Sub

[mrmmickle1]

Admin,

Thanks so much. I modified it by adding more search keys and got it to work for my needs! I appreciate the help. Here is my Final Product:

Sub GroupStatusbyInsertingUniqueValue()
    
    Dim i As Long, j As Long, r As Range, ff As String
    Dim SearchKeys1, SearchKeys2, SearchKeys3, SearchKeys4, SearhKeys5, SearchKeys6, _
    SearchKeys7, SearchKeys8, SearchKeys9, SearchKeys10, SearchKeysAll, Replacement
    
    SearchKeys1 = Array("Open", "Received", "Preliminary Ins", "Pre Test", "Insp-APU")
    SearchKeys2 = Array("Approved", "Disassemble", "RETURN AS IS", "Waiting Parts", "Waiting Compone", "Assembly", _
    "Test", "Post Test", "QEC", "QC", "QC Discrepancy", "Shipping Prep", "Assembly-APU")
    SearchKeys3 = Array("Clean")
    SearchKeys4 = Array("Inspection")
    SearchKeys5 = Array("Customer Servic")
    SearchKeys6 = Array("Lease")
    SearchKeys7 = Array("Quote on Hold", "Quote")
    SearchKeys8 = Array("Closed", "Invoicing")
    SearchKeys9 = Array("Parking Lot")
    SearchKeys10 = Array("Waiting App.")
    
    
    SearchKeysAll = Array(SearchKeys1, SearchKeys2, SearchKeys3, SearchKeys4, SearchKeys5, _
    SearchKeys6, SearchKeys7, SearchKeys8, SearchKeys9, SearchKeys10)
    
    Replacement = Array("GATE 1", "GATE 2", "GATE 3", "GATE 4", "CUSTOMER SERVICE", "LEASE", "QUOTE", "SHIPPED", "SURPLUS PARTS", "WAITING APPROVAL")
    
    With Intersect(ActiveSheet.UsedRange, Columns(4))
        For i = LBound(Replacement) To UBound(Replacement)
            For j = LBound(SearchKeysAll(i)) To UBound(SearchKeysAll(i))
                Set r = .Find(SearchKeysAll(i)(j), lookat:=2)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        Set r = .FindNext(r)
                        r.Offset(, 10) = Replacement(i)
                    Loop Until r.Address = ff
                End If
            Next
        Next
    End With
    
End Sub

[Admin]

Thanks for the feedback

[mrmmickle1]

After using the below code for a few days I have realized that it is not functioning properly in regards to one value: "Pre Test" When this value is found instead of inserting the value: "Gate 1" as I anticipate it inserts "Gate 2". I am unsure of why this is happening. I need it to insert "Gate 1" as later in the code I use this value to Outline the data into groups.

Here is the code and file I am having trouble with:

ub FormatQuantumDataDumpCS()
' Rearranges Data into the correct format and inserts correct titles for Header Row
    Columns("B:E").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:N").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
    Columns("F:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:AA").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "W/O #"
    Columns("D:D").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("D:D").Select
    Selection.Cut
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Model"
    Columns("E:E").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Date In"
    Columns("G:G").Select
    Selection.Cut
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Date Quoted"
    Columns("H:H").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Date App"
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Ship Date"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Cost Analysis"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Revenue"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Margin"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Credit"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "Notes"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "Unique"
    Columns("A:A").ColumnWidth = 27    'This is where I change column width and format Column J to Currency
    Columns("M:M").ColumnWidth = 36
    Columns("J:J").ColumnWidth = 20
    Columns("J:J").Select
    Selection.NumberFormat = "$#,##0.00"
    Range("A1").Select
    
End Sub
Sub GroupStatusbyInsertingUniqueValueCS()

'Searches for values in column D and if Found, Inserts New value (Replacement) in Column N
    
    Dim i As Long, j As Long, r As Range, ff As String
    Dim SearchKeys1, SearchKeys2, SearchKeys3, SearchKeys4, SearhKeys5, SearchKeys6, _
    SearchKeys7, SearchKeys8, SearchKeys9, SearchKeys10, SearchKeysAll, Replacement
    
    SearchKeys1 = Array("Pre Test", "Open", "Received", "Preliminary Ins", "Insp-APU", "Pending", "Inspection", "Clean", "Pre-Test")
    SearchKeys2 = Array("Approved", "Disassemble", "RETURN AS IS", "Waiting Parts", "Waiting Compone", "Assembly", _
    "Test", "Post Test", "QEC", "QC", "QC Discrepancy", "Shipping Prep", "Assembly-APU")
    SearchKeys3 = Array("Customer Servic")
    SearchKeys4 = Array("Lease")
    SearchKeys5 = Array("Quote on Hold", "Quote")
    SearchKeys6 = Array("Closed", "Invoicing")
    SearchKeys7 = Array("Parking Lot")
    SearchKeys8 = Array("Waiting App.")
    SearchKeys9 = Array("Weld", "Balance Shop", "Cancelled", "Strip Coating", "Waiting Concess", "Machine Shop", "NDT", _
    "Grind Shop", "Paint", "Plating", "Chrome/Cad", "Chrome Strip", "Shot Peen", "Outside Vendor", "Waiting manual", "Quoted for Exch", _
    "Sub-Assembly", "Insp-LH", "Assembly-LH", "PO AN LRU", "Harness-LG", "concession")
    
    
    SearchKeysAll = Array(SearchKeys1, SearchKeys2, SearchKeys3, SearchKeys4, SearchKeys5, _
    SearchKeys6, SearchKeys7, SearchKeys8, SearchKeys9)
    
    Replacement = Array("GATE 1", "GATE 2", "CUSTOMER SERVICE", "LEASE", "QUOTE", "SHIPPED", "SURPLUS PARTS", "WAITING APPROVAL", "OTHER")
    
    With Intersect(ActiveSheet.UsedRange, Columns(4))
        For i = LBound(Replacement) To UBound(Replacement)
            For j = LBound(SearchKeysAll(i)) To UBound(SearchKeysAll(i))
                Set r = .Find(SearchKeysAll(i)(j), lookat:=2)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        Set r = .FindNext(r)
                        r.Offset(, 10) = Replacement(i)
                    Loop Until r.Address = ff
                End If
            Next
        Next
    End With
    
End Sub

I run the code in this sequence:

Sub CorrectSequence()

Call FormatQuantumDataDumpCS
Call GroupStatusbyInsertingUniqueValueCS

End Sub

Can any one help me to fix this code were it will use the replacement "Gate 1" when the value "Pre Test" is found? ANy advice or help would be much appreciated.

[mrmmickle1]

I was able to resolve this issue by changing the order of search keys 1 and 2 and now the code seems to work fine.

[tfurnivall]

Hi mrmmickle!

Your problem (originally) seemed to be:

How can I insert a value into a cell, based on the contents of another cell in the same row. Given that you dramatically expanded the number of phrases to check for, and the number of replacements, would it not be easier to divide the task into 2 separate pieces?

1. Build the list of phrases to check for, and the associated replacement phrase, and

2. Search through the column, and and see how many 'replacements' you can make.

Task #1 is easily defined as an array - of two dimensions

Const MaxElements = 100
Const NumColumns = 2

Dim ReplacementChart(MaxElements, NumColumns) As String

(By using the symbolic constants you need only change one place whenever you refer to the ReplacementChart)
Loading this array is left "as an exercise for the reader", but my guess is that you may want to have a separate sheet where it resides, and allow the array simply to read data from that sheet. Either way, not a really big deal.

Task #2 involves a little bit more effort:

Const ColumnToSearch = "A"    '   or whatever column you want to use to find those phrases
Const ColumnToReplace = "E"      '   or whatever you decide - this is 4 columns over, as you requested)
Const MatchPhrase = 1
Const ReplacePhrase = 2
Const FirstElement = 0             '   from the system definition of the first row in an array. Could also be 1
Const MaxElements = 100      '   From how ever you set up the ReplacementChart array in task 1

Dim FirstRowToCheck As Integer
Dim LastRowToCheck As Integer
Dim sheet As Worksheet      '   You do need to set this to the sheet where you want to work, whatever it's called.....

Dim r As Integer        '   Row we are looking at
Dim l As Integer        '   line in the Replacement Chart
For r = FirstRowToCheck To LastRowToCheck
    l = FirstElement
    While l < MaxElements
           If ReplacementChart(l, MatchPhrase) = sheet.Range(ColumnToSearch + Format(r)) Then
              l = MaxElements       '   Force the While loop to terminate
              sheet.Range(ColumnToReplace + Format(r)) = ReplacementChart(l, ReplacementPhrase)
           End If
           l=l+1
    Wend

Purists will argue that this is an inefficient algorithm, because it forces you to do a sequential scan of a range, and then check every entry in the Replacement Chart.
I'd say that you only search the ReplacementChart until you find a match, and no cell can possibly have more than one match. I think that the clarity of the algorithm will make it easier when you refine your requirements (as you have done already ;-)


HTH - if not now, perhaps in the future!

Tony

[mrmmickle1]

Tony,

Thank you for the time and effort you have put into this. It makes a lot of sense, however some elements are a little confusing to me, simply because this is the first time I am seeing them. I will have to review this further and look up a few of the terms and uses. It looks very thorough though. I am sure I can figure it out. This helps a lot. Thanks!!