Incrementally Update QTY with each MATCH while Looping Challenge?

[ChrisOK]

I'm trying to figure out a way to Incrementally Update the QTY each time a match is found while bouncing it against another sheet within the same workbook.

Here's an example:
Start with "PARTS" sheet, row 2, look for this part # "12345" in the "INVENTORY" sheet, row 2.
If match = turn both part # cells BOLD FONT on both sheets.
Notice that the QTY is 5 on the "INVENTORY" sheet,
COPY the QTY of the "INVENTORY" sheet of '5' to the "PARTS" sheet. (overwrite the '1') this 1st time thru the loop.

Continue to look for that SAME part # on row 3 of the "INVENTORY" sheet.
If no match = continue to row 4 on "INVENTORY" sheet.
If another match is found on row 4 of "INVENTORY" sheet, turn the part # cells BOLD FONT
then SUM the QTY shown on the "INVENTORY" sheet '5' to what was previously pasted on the "PARTS" sheet '5'.
The "PARTS" sheet should now show the updated QTY of '10'

Continue with loop, an look to row 5 of "INVENTORY" sheet for additional matches...
If another match is found on row 5 of "INVENTORY" sheet, turn that part # cell BOLD FONT
then SUM the QTY shown on the "INVENTORY" sheet '15' to what was previously pasted on the "PARTS" sheet '10.
The "PARTS" sheet should now show the updated QTY of '25.
THE GOAL is to CONTINUALLY UPDATE THE QTY OF THE "PARTS" sheet based on matches/qtys reported on "INVENTORY" sheet.

Walk Thru Steps That Occured:
The QTY of 1 got overwritten and changed to 5 on the first match pass...
Then QTY got updated to QTY of 10 (5+5) found on the 2nd match pass...
Then QTY got updated to QTY of 25 (10+15) found on that last match pass..

===============================
...SHEET: "PARTS"
1..DESC......PART#.....QTY....
-----------------------------
2..bolt........12345......1......
3..clamp.....78787.......7......
4..screw.....12345.......9......

===============================
.
===============================

...SHEET: "INVENTORY"
1..QTY....DESC......PART#.....
----------------------------------
2..5......bolt......12345.....
3..3......wing......94566.....
4..5......bolt......12345.....
5..15.....bolt......12345.....
===============================

 

[pleeseemailme]

Chris, use this code to highlight the text red:

Sub Mod_12_BOM2TO()

'GETS RID OF GHOST CHARACTERS THAT TRIM AND CLEAN WOULD NOT CLEAR!!!
'.......this ghost spacing was preventing other code from locating a match when
'.......it tried to compare to Part Numbers...
'.......Matches were clearly present but unrecognized due to the char issue
'.......rendering no matches between the "TO" sheet and the "BOM" sheet
     
 'Sub EveryCharacter()
    Sheets("TO").Select
 
    Dim i As Long
    Dim L As Long
    Dim c As Range
    Dim r As String
    Dim rng As Range
 
     'Range to search/replace
    Set rng = Range("G8:G5000")
    'TO DO THE ENTIRE ACTIVE SHEET USE THIS LINE OF CODE INSTEAD: < < doesnt work =-(
    'Set rng = ActiveSheet.UsedRange    < < doesnt work =-(
 
     'Every Cell!
    For Each c In rng
         'Get length of string in cell
        L = Len(c)
         'If blank go next
        If L = 0 Then GoTo phred
         'Every character...
        For i = 1 To L
            r = Mid(c, i, 1)
             'If current char is outside 'normal' ASCII range
            If r < Chr(32) Or r > Chr(126) Then
                 'delete it
                c.Replace what:=r, replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByColumns, MatchCase:=False
            End If
             'else get next character in cell
        Next
phred:
         'Get next cell
    Next c
    
'------------------------------------------------
'Sub IncrementalMatchSumTotQtyBOM2TO()


'THIS ONE WORKS GREAT FOR COMPARING THE 2 SHEETS, LOOKING FOR PART # MATCHES, IF FOUND, IT WILL SUM TO TOTAL QTYS OF EACH
'OF THE MATCHES FOUND.
'IF IT FINDS PART #12345 WITH 10 AND FINDS IT AGAIN WITH 5 AND FINDS IT A 3RD TIME WITH 5 IT SUMS THE TOTAL TO "20"
'IT SUMS THE TOTAL AND PASTES IT ON THE "BOM" SHEET WHILE USING THE "TO" SHEET AS JUST A LOOKUP TABLE WHILE SUMMING.
'IF A TEXT CODE IS FOUND IN COL G OF "TO", IT SHOULD SIMPLY COPY THAT CODE OVER COL E OF "BOM"
    
    Sheets("BOM Worksheet").Select
    
    Range("E5:E100").NumberFormat = "General"
'    Range("E5").Select
'    ActiveCell.FormulaR1C1 = _
'        "=SUMIF(TO!R8C2:R100C2,'BOM Worksheet'!RC16,TO!R8C7:R100C7)"
    
    
    'Range("E5:E100").NumberFormat = "General"
    Range("E5").Select
    Range("E5:E" & Range("A" & Rows.Count).End(xlUp).Row).FormulaR1C1 = _
    "=IF(ISTEXT(OFFSET(TO!R1C7,MATCH('BOM Worksheet'!RC[11],TO!R2C2:R50000C2,0)," & _
    "0)),OFFSET(TO!R1C7,MATCH('BOM Worksheet'!RC[11],TO!R2C2:R50000C2,0),0)," & _
    "SUMIF(TO!R8C2:R100C2,'BOM Worksheet'!RC[11],TO!R8C7:R100C7))"




    
  Dim Nmbr As Double
Application.Calculation = xlCalculationManual
For i = 2 To WorksheetFunction.Count(Sheets("BOM Worksheet").Range("P:P")) + 1
    Nmbr = Sheets("BOM Worksheet").Range("P" & i)
    For Each cell In Sheets("TO").Range("B8:B" & Range("B" & Rows.Count).End(xlUp).Row + 1)
        If cell.Value = Nmbr Then
        Sheets("BOM Worksheet").Range("P" & i).Font.Bold = True
        cell.Font.Bold = True
        End If
    Next cell
Next i
Application.Calculation = xlCalculationAutomatic


'------------------------------------------------
'Sub ChangeColor()
    Application.ScreenUpdating = False
    Dim lRow As Long
    lRow = Range("E" & Rows.Count).End(xlUp).Row
    Dim MR As Range
    Set MR = Range("E5:E" & lRow)
    Dim cel1 As Range
    Dim cel2 As Range
    If Application.WorksheetFunction.CountIf(Range("E5:E" & lRow), 0) >= 1 Then
        MsgBox ("Zero values were discovered. Do not delete these, they'll be used during File Mtc")
    End If
    For Each cel1 In MR
        If cel1 = 0 Or WorksheetFunction.IsText(cel1.Value) = True Then
            cel1.Interior.Color = RGB(255, 0, 0)
        End If
    Next cel1
    If Application.WorksheetFunction.CountIf(Range("C2:C" & lRow), 0) = 0 Then
        'MsgBox ("No Zero values were found. Proceed with your TO to BOM validation.")
    End If
    For Each cel2 In MR
        If cel2 > 0 And WorksheetFunction.IsText(cel2.Value) = False Then
            cel2.Interior.Color = RGB(255, 255, 255)
                
        End If
    Next cel2
    Application.ScreenUpdating = True


End Sub

However, highlighting the cells red can be set up dynamically (real-time) by using a conditional formatting formula. You wouldn't need the last part of your code. if you place the formula =OR(ISTEXT(E5),E5=0) into the conditional formatting 'use a formula' section while you have cells E5 to E5000 (or whatever) selected. Make sure E5 is the active cell and it will do the same as your code. Oh, and you'll have to select the 'Format...' button to select the red background fill color, otherwise it will do nothing. I hope that helps.

 

[ChrisOK]

GENIOUS!! Itsa' beaut!

The code is attached to a toolbar icon that runs it when the analyst gets to this stage in their procedure.
The auto-colorization is more preferred as they are in a hurry (working thousands of line items in various sheets and workbooks)
and last, not everyone is equally as familiar with manually conditionally formatting their data so I'm trying to make it dummy-proof and expeditious for all...
Having it embedded into the code keeps what they are doing more uniform - and is much more expeditious.
What's your favorite go-to drink?

 

[pleeseemailme]

I'm not sure I don't go-to very often. But, I am glad we got this working for you! I hope it makes you seem like a hero at work. Have a good one.

 

[ChrisOK]

LOL - no worries - Go-To can be as simple as a nice tall Suth'n Ice Tea or Starbucks Salted Caramel Macchiato --
Hero? Not yet --
I'm still battling that stupid clean-up code for the last task of the project... (the one where we were trying to get the code "clean" so matches could take place)...

As you might recall the below code got it working one-directional - (I've adjusted it to go the opposite direction and cleans up the PN column on the TO sheet (Column B) so it can compare the TO sheet to the BOM sheet and try to match Part #'s)

>> If a match is found, DO NOTHING,
>> If a match IS NOT FOUND, then this time, it shoud copy that PN over to the base of the BOM sheet.
It also copies over the Qty (Col G of TO sheet) and the NOUN/Desc (Col F of the TO sheet).
IT WORKS BEAUTIFULLY ON A HAND-TYPED FILE -- but again, doesnt work on this file that has data from an outside system.

Sub Mod_111_12_BOM2TO()

'GETS RID OF GHOST CHARACTERS THAT TRIM AND CLEAN WOULD NOT CLEAR!!!

'Sub EveryCharacter()
     
    Dim i As Long
    Dim L As Long
    Dim c As Range
    Dim r As String
    Dim rng As Range
     
     'Range to search/replace
    Set rng = Range("B8:B200")
     
     'Every Cell!
    For Each c In rng
         'Get length of string in cell
        L = Len(c)
         'If blank go next
        If L = 0 Then GoTo phred
         'Every character...
        For i = 1 To L
            r = Mid(c, i, 1)
             'If current char is outside 'normal' ASCII range
            If r < Chr(32) Or r > Chr(126) Then
                 'delete it
                c.Replace what:=r, replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByColumns, MatchCase:=False
            End If
             'else get next character in cell
        Next
phred:
         'Get next cell
    Next c
End Sub

- but can't get it working going the opposite direction... (the TO sheet needs to be compared to the BOM sheet looking for any variances -- but of course, the lookup matching code won't work because the data is not clean)... I tried simply changing the column refs, but I believe I need it to clean more than one column and this code only accomodates cleaning a single column "B8:B")
Is there a way to make that code clean the whole page -- rather than only clean a single column?

This is what it is supposed to do if it DOES NOT FIND A MATCH:
Compare

'======================================
'.......continued from the code above....... 
'.......this code runs following the clean up
    Sheets("TO").Select

Dim x As Range, pnrng As Range, nr As Long
Application.ScreenUpdating = False
With Sheets("TO")
  For Each x In .Range("B8", .Range("B" & Rows.Count).End(xlUp))
    Set pnrng = Sheets("BOM Worksheet").Columns(16).Find(x.Value, LookAt:=xlWhole)
    
'IF NO MATCH BETWEEN "B" OF TO AND "P" OF BOM THEN COPY THE "B" PN FROM TO to the base of the BOM
'ALSO COPY THE NOUN "O", THE UPA "E" to the base of the BOM

    If pnrng Is Nothing Then
      nr = Sheets("BOM Worksheet").Range("P" & Rows.Count).End(xlUp).Offset(1).Row
      With Sheets("BOM Worksheet").Range("P" & nr)
        .Value = x.Value
        .Font.FontStyle = "Bold"
        .Font.Color = 255
      End With
      
      With Sheets("BOM Worksheet").Range("O" & nr)
        .Value = x.Offset(, 4).Value
        .Font.FontStyle = "Bold"
        .Font.Color = 255
      End With
      
      With Sheets("BOM Worksheet").Range("E" & nr)
        .Value = x.Offset(, 5).Value
        .Font.FontStyle = "Bold"
        .Font.Color = 255
      End With
      
    End If
  Next x
  
End With
With Sheets("BOM Worksheet")
  .Columns("E:E").AutoFit
  .Columns("O:P").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

 

[ChrisOK]

Here's what it should look like after using both toolbar icons:
A copy of the small test file was uploaded here: https://app.box.com/s/0ysocva9ihmctcbhp2mx

The 1st Toolbar Icon when clicked - Compares the BOM sheet to the TO sheet.
.....populates the UPA/Qty and turns items red that are = to "0" or code

The 2nd - Compares the TO sheet back to the BOM sheet - looking for variances (line items that may need to be added to the BOM).
........if the Part # on the TO is NOT FOUND on the BOM, it will add it to the base of the BOM sheet in red (with other key info extracted from the TO tab)

Code works great on the hand-typed test file,
...but when attempting to use it on a real file that has data from an outside system, does not work... It simply does not find any matches and does not add anything to the base of the sheet as it should.

TRIM and CLEAN were tried with no luck
Need something that will do all three perhaps?
(RIM, CLEAN and the CHAR replacement so whatever the issue is -- it will clean it thoroughly )

~distraught~
looks like a long wk-end ahead...

 

[pleeseemailme]

ChrisOK,
It looks like your question is with expanding the range of the VBA cleaning function above and not with with the code following the clean up. You want to expand the range from column B to the the entire sheet. This may make your code run unbearably long but you can replace the 'Set rng = Range("B8:B200")' line with 'Set rng = ActiveSheet.UsedRange' This will loop through every letter and every cell that has data in it in the active sheet. Just make sure you've got the correct sheet activated. I hope this is what you are looking for.

 

[ChrisOK]

Thanks Pleeseemailme, I found this and it cleans everything! Works like a charm... (yes, it takes a few seconds to run - but it works and that's top priority now to get the project moving again)...

Thanks for the replace info -- Good info to know/learn --
I'm sure I'll be able to use that in the very near future --
To Use: Highlight the data needing cleaned (I selected the whole sheet), then ran the code...

Sub TrimALLMcRitchie()

   'David McRitchie 2000-07-03 mod 2002-08-16 2005-09-29 join.htm
   '-- http://www.mvps.org/dmcritchie/excel/join.htm#trimall
   ' - Optionally reenable improperly terminated Change Event macros
   
      Application.DisplayAlerts = True
      Application.EnableEvents = True   'should be part of Change Event macro
   If Application.Calculation = xlCalculationManual Then
      MsgBox "Calculation was OFF will be turned ON upon completion"
   End If
   
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim cell As Range
   'Also Treat CHR 0160, as a space (CHR 032)
   Selection.Replace What:=Chr(160), replacement:=Chr(32), _
     lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Selection.Replace What:=Chr(13) & Chr(10), replacement:=Chr(32), _
        lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Selection.Replace What:=Chr(13), replacement:=Chr(32), _
        lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Selection.Replace What:=Chr(21), replacement:=Chr(32), _
        lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   '---------------------------
   Selection.Replace What:=Chr(8), replacement:=Chr(32), _
      lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Selection.Replace What:=Chr(9), replacement:=Chr(32), _
      lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   'Trim in Excel removes extra internal spaces, VBA does not
   On Error Resume Next
   For Each cell In Intersect(Selection, _
      Selection.SpecialCells(xlConstants, xlTextValues))
     cell.Value = Application.Trim(cell.Value)
   Next cell
   On Error GoTo 0
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub