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 :cheers:

[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!!