Results 1 to 8 of 8

Thread: Offset based on Values in Column E

  1. #1
    Member mrmmickle1's Avatar
    Join Date
    Sep 2012
    Posts
    51
    Rep Power
    13

    Offset based on Values in Column E

    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:

    Code:
    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
    Code:
    Next
    and
    Code:
    For rfound
    into the code but I am unfamiliar with this process can someone please help me out? It would be much appreciated
    Using Excel 2010

  2. #2
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi

    Try something like this.

    Code:
    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
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #3
    Member mrmmickle1's Avatar
    Join Date
    Sep 2012
    Posts
    51
    Rep Power
    13
    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:

    Code:
    
    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
    Using Excel 2010

  4. #4
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Thanks for the feedback
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  5. #5
    Member mrmmickle1's Avatar
    Join Date
    Sep 2012
    Posts
    51
    Rep Power
    13

    Troubleshooting Code with Error in Process

    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:

    Code:
    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:
    Code:
    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.
    Attached Files Attached Files
    Last edited by mrmmickle1; 12-03-2012 at 09:16 PM.
    Using Excel 2010

  6. #6
    Member mrmmickle1's Avatar
    Join Date
    Sep 2012
    Posts
    51
    Rep Power
    13
    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.
    Using Excel 2010

  7. #7
    Junior Member
    Join Date
    Dec 2012
    Posts
    12
    Rep Power
    0
    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

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

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

  8. #8
    Member mrmmickle1's Avatar
    Join Date
    Sep 2012
    Posts
    51
    Rep Power
    13
    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!!
    Using Excel 2010

Similar Threads

  1. Replies: 10
    Last Post: 05-23-2013, 12:30 PM
  2. Replies: 17
    Last Post: 05-22-2013, 11:58 PM
  3. How to make Dynamic range (width) with OFFset function
    By Rajesh Kr Joshi in forum Excel Help
    Replies: 12
    Last Post: 12-01-2012, 11:03 PM
  4. Group Pivot Data Based On Row Values In One Column
    By mrmmickle1 in forum Excel Help
    Replies: 10
    Last Post: 10-09-2012, 11:46 PM
  5. Replies: 3
    Last Post: 08-05-2012, 09:16 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •