Macro Compare Cells

[jjlafond]

Hello,

I used a UserForm to enter information into a few cells in Sheet1. On Sheet2, I have a column of codes (ie 23456; 25678; 12345MD; 15389MD). I am trying to compare one cell from sheet1 to the top cell in sheet2, and if it does not match, move down the column until it does. The BOLD is the part of the code that isn't working.

Now the specifics: sh1.Range("D2") is the first cell I want to compare. It does not change. I'm comparing it one at a time to the values in column B of sheet2 until sh1.D2 matches sh2.Bj. The column contains two types of entries. All entries starting with 2##### contain only numbers. All entries starting with 1####MD all end in two letters.

The UserForm pops up immediately upon opening the excel sheet. sh1.D2 is filled soon thereafter. If the entered number starts with a 2, its stays as entered. If the entered number starts with 1, the code ensures that it ends in MD.

When comparing, if no match is found, a message box appears saying there is not match, and the UserForm re-appears until the entered number matches an entry in sh2.Bj column.

The code as is works for proper entries that begin with a 1####. It does NOT work at all for numbers that begin with 2####. I have CONFIRMED that the values in sh1.D2 do match a cell value in the colum by having message boxes appear showing sh1.D2 next to sh2.Bj and have visually seen a match, but the macro passes the match and proceeds though the cycle. Data entries starting with 2### are the only part of this that do not work at the time I copied this into Mr.Excel.

I know its a lot of code, but I can't figure out whats wrong for the life of me, and there may be something I'm missing in an early line. If I can provide any more information to help figure this out, let me know.

The BOLD is the part of the code that isn't working.




Sub Autpen()
If Range("D2").Interior.ColorIndex = 3 Then
ActiveWorkbook.RefreshAll 'Under "Data" Tab / Connections / "TOOLS AND PARTS NUMBERS Sheet" Properties all Refresh Controlos
DoEvents
frmPartsData.Show
Else
MsgBox "Mold X & R chart: Job " & Range("H2")
End If
End Sub





Sub Pull_Info()
Unload frmPartsData

Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Mold X & R Template")
Set sh2 = Worksheets("Part Data")
Dim j As Long
Dim lastrow As Long


lastrow = sh2.Cells(Rows.Count, "B").End(xlUp).Row
For j = 2 To lastrow
If sh1.Cells(2, "D").Value = sh2.Cells(j, "B").Value Then
sh1.Cells(2, "A").Value = sh2.Cells(j, "A").Value
sh1.Cells(2, "K").Value = sh2.Cells(j, "E").Value
sh1.Cells(1, "O").Value = sh2.Cells(j, "D").Value
j = lastrow + 1
Call SaveMe
ElseIf j = lastrow Then
MsgBox "The Part # is Invalid"
frmPartsData.Show
End If
Next
End Sub






Sub SaveMe()
MsgBox "I'm Done!"
End Sub

This UserForm is "similar" to the one I created. I could not copy mine in. Replace Forename with Part ID, and there is only one button labeled "Enter."

When the Enter button on the UserForm is clicked:

Private Sub Enter_Click()


'Forces Part ID to be entered to continue in text box
If Trim(Me.txtPartID.Value) = "" Then 'If Part ID box is empty...
Me.txtPartID.SetFocus
MsgBox "Please enter a Part ID" 'Popup warning box that requires Part ID
Exit Sub
End If


'Forces Order ID to be entered to continue in text box
If Trim(Me.txtOrder.Value) = "" Then 'If Order No box is empty
Me.txtOrder.SetFocus
MsgBox "Please enter an Order #" 'Popup warning box that requires Order No
Exit Sub
End If


Range("D2").Value = Me.txtPartID.Value
Range("H2").Value = Me.txtOrder.Value
Range("N3").Value = Me.txtLot.Value


If Virgin.Value = True Then
Range("P2").Value = "Virgin"
ElseIf (Me.Frac1.Value <> "" And Me.Frac2.Value <> "") Then
Range("P2").Value = "Regring: " & Me.Frac1.Value & "/" & Me.Frac2.Value
ElseIf Regrind.Value = True Then
Range("P2").Value = "Regrind: / "
End If




' If previously identified areas are NOT blank, the fill color changes to gray
'If left black, the color will remain red indicating the need to fill them
If Range("D2").Value <> "" Then
Range("D2").Interior.ColorIndex = 15
End If


If Range("H2").Value <> "" Then
Range("H2").Interior.ColorIndex = 15
End If


If Range("N3").Value <> "" Then
Range("N3").Interior.ColorIndex = 15
End If


If Range("P2").Value <> "" Then
Range("P2").Interior.ColorIndex = 15
End If


DoEvents
If (Not Range("D2").Value Like "**MD**" And Range("D2").Value <> "" And InStr(Range("D2").Value, "2") <> 1) Then
Range("D2").Value = Range("D2").Value & "MD"
End If


Call Pull_Info
Unload Me


End Sub

 

[JoeMo]

I haven't looked at all your code in detail, but this might help.

First, it looks like your column of codes come from a data connection. If so, I would not trust visual comparisons to determine if codes that nominally begin with 2 are the same as what's in range D2 of sheet1. Imported data often have some spaces or other non-visual characters included. You may need to "clean-up" the imported data on sheet2 before you compare it to sheet1.

Here's a test you can try. Say you think, from visual observations, that Sheet1 D2 is a match to Sheet2 B2 when both these cells start with a "2". In any empty cell enter: =EXACT(Sheet1!D2,Sheet2!B2)
What does that return?

Second comment. You can save a lot of looping time by using:

Dim n as Variant
On Error Resume next
n = Application.Match(Sheets("Sheet1").Range("D2"),Sheets("Sheet2").Range("B2:B100"),0)
On Error GoTo 0
If Isnumeric(n) Then 'a match was found
'rest of code

rather than comparing sh1 D2 to sh2 col B one cell at a time.

 

[jjlafond]

Thanks for the quick response, if only I could be as fast!


=EXACT('Mold X & R Template'!D2,'Part Data'!B11) retruns True
But:
=SUM('Mold X & R Template'!D2,'Part Data'!B11) only has the value of D2 an is missing the value on the second sheet

As far as the looping. There aren't many cells to check, and I am a novice at VBA, so I'll stick with what I can comprehend at the moment. I can go back and modify that when the rest of this code is working, but thank you.

 

[jjlafond]

I finally found a working solution, hopefully anyone else with a similar problem will find this useful:

I found this excerpt on another Mr.Excel thread:
Select all the cells in that column. Go to Data-->Text To Columns [I chose option Fixed Width] and press finish.

Visually this shifted all data entries with only numbers to the right side of the columns. I am not sure what else this actually did, except MAYBE reformat the column into something more useful since the table was being pulled from another excel workbook.

So I added this section of code before the search happens and now it is working entirely!

sh2.Activate
sh2.Columns("B:B").Select
Selection.TextToColumns Destination:=Range( _
"Table_TOOLS_AND_PART_NUMBERS_Sheet1__1[[#Headers],[PART1]]"), DataType:= _
xlFixedWidth, FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
sh1.Activate