Col A holds a Book/Chapter refc from a Tech Order in the following "General" =ISTEXT (true) format:
"11/1"
" /2"
" /3"
"12/1"
This format gets converted when the following code runs and I need it to leave Column A of the "TO" alone (don't convert).
Or, convert Col A back to look like its original format shown above...
Does anyone know some code that will convert it back?
Or know how to adjust the current code to - keep it from converting Column A of the "TO" sheet?
"11/1"
" /2"
" /3"
"12/1"
This format gets converted when the following code runs and I need it to leave Column A of the "TO" alone (don't convert).
Or, convert Col A back to look like its original format shown above...
Does anyone know some code that will convert it back?
Or know how to adjust the current code to - keep it from converting Column A of the "TO" sheet?
Code:
Sub Mod_13_TO2BOM()
'Cleans to appropriately allow MATCHING to take place between the 2 sheets w/ the PN#
'========================================================
'Sub Macro1_SelectFullSheet()
'
'
Sheets("TO").Select
Cells.Select
'THIS IS CRITICAL CODE!! IT WILL CLEAN DATA OR ENTIRE SHEET OF DATA THAT HAS BEEN BROUGHT IN FROM AN
'OUTSIDE MAIN FRAME SYSTEM. IT WILL CLEAN EVERYTHING THAT MIGHT PREVENT YOUR LOOK UP MATCHING CODE FROM
'APPROPRIATELY FINDING MATCHES. To Use: Select data or sheet needing cleaned, then run. (or add the code
'to this code to select desired range)
'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
'=============================================================
'Sub CompareAndHighlight()
'THIS LOOKS FOR CELLS THAT >>> DO <<< MATCH AND HIGHLIGHTS THEM
'....shows green highlighted rows on the TO so the analyst knows these were found on the BOM and accounted for
'....leaves the items not found with no colorization
'Works GREAT!
Sheets("TO").Select
Range("A1").Select
Dim rng1 As Range, rng2 As Range, k As Integer, j As Integer
Dim isMatch As Boolean
For k = 7 To Sheets("TO").Range("B" & Rows.Count).End(xlUp).Row 'START ON ROW 7
isMatch = True
Set rng1 = Sheets("TO").Range("B" & k)
For j = 5 To Sheets("BOM Worksheet").Range("P" & Rows.Count).End(xlUp).Row 'START ON ROW 5
Set rng2 = Sheets("BOM Worksheet").Range("P" & j)
If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
isMatch = False
Exit For
End If
Set rng2 = Nothing
Next j
'<<<>>>>THE BELOW SHOWS HOW TO HIGHLIGHT IN 3 DIFFERENT WAYS
'>>>>>>>>>HIGHLIGHT ONLY A CELL
'>>>>>>>>>HIGHLIGHT A ROW TO INFINITY
'>>>>>>>>>HIGHLIGHT A ROW ONLY OUT TO THE END OF WHERE DATA EXISTS
If Not isMatch Then
'rng1.Interior.Color = RGB(173, 255, 47) 'THIS ONE highlights ONLY THE CELL
'rng1.EntireRow.Interior.Color = RGB(173, 255, 47) 'THIS ONE highlights ENTIRE ROW (to infinity)
With Sheets("TO")
.Range(.Range("A" & rng1.Row), .Cells(rng1.Row, .Columns.Count).End(xlToLeft)).Interior.Color = RGB(173, 255, 47)
End With
'rng1.Value = "Incorrect Name" 'THIS LINE ACTUALLY overwrites the cell with "incorrect name" not sure
'...............................why anyone would want this - but keeping it in the event I see a need
End If
Set rng1 = Nothing
Next k
'End Sub
'====================================================================
'BOTH TO TO BOM AND BOM to TO MODS WORK PERFECTLY ON "12345 TEST" FILE
'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
'================================================
'THIS IS THE ORIG CODE BUT IT IS NOT WORKING PROPERLY
'THE PROBLEM IS THAT I NEED SEVERAL COLUMNS CLEANED SO A PROPER MATCH CAN TAKE PLACE
'NEED TO CLEAN B AND G OF THE "TO" TAB SO IT CAN COMPARE THOSE TO THE "BOM" TAB
'Range to search/replace
Set rng = Range("B8:B5000")
'================================================
'THIS IS THE NEW CODE BUT IT IS CAUSING ERROR ON L=LEN(C) ROW
'COMMENTING IT OUT FOR NOW UNTIL RESOLVED
'TO DO THE ENTIRE ACTIVE SHEET USE THIS LINE OF CODE INSTEAD:
'Set rng = ActiveSheet.UsedRange
'================================================
'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
'========================================================
Sheets("TO").Select
Dim x As Range, pnrng As Range, nr As Long
Application.ScreenUpdating = False
With Sheets("TO")
For Each x In .Range("B7", .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