wxcel

Sub NPIstage()
    Application.DisplayAlerts = False
    Application.Calculation = xlManual
    Application.EnableEvents = False

    Dim AB As String
    Dim A, B, C As Worksheet
    Dim N1, N2, N3, N4, N5, N6, S1, S2, S3, CP1, CR1, PR1, CC1, PC1, CR2, PR2, CC2, PC2, cr3, fc As Range
    Dim R1, i, i1, i2, i3, i4, MR, lr, nr, C1, C2, C3, C4, C5 As Long
    Dim dict As Object
    Dim v As Variant
    Dim ts As Long
    Dim cs As Long



    Call RunSQLQuery

    AB = ThisWorkbook.Name

    Set A = Workbooks(AB).Sheets("KIOXIA BOMs Format")
    Set B = Workbooks(AB).Sheets("NPI Operation Check")
    Set C = Workbooks(AB).Sheets("84KIC")

    C1 = 7
    C2 = 4
    C3 = 5
    C4 = 6
    C5 = 8
    MR = 500

    ts = 9
    cs = 0
    B.Cells(1, 3).Value = "Progress: 0%"



    With B.Range("B3:B5").Interior
    .Color = vbYellow
    End With
    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"




    B.Rows("7:70000").Delete

    Set N1 = A.Rows("1:99").Find("*Maker*Product*Number")
    If N1 Is Nothing Then
        Set N1 = A.Rows("1:99").Find("*Product*N")
    End If

    If Not N1 Is Nothing Then
        i = N1.row + 1
        R1 = 7
        Do While i <= A.Cells(A.Rows.Count, N1.Column).End(xlUp).row And R1 <= 7 + MR
            B.Cells(R1, C1).Value = A.Cells(i, N1.Column).Value
            R1 = R1 + 1
            i = i + 1
        Loop
    End If

    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"


    Set N2 = A.Rows("1:99").Find("Parts Code")
    If N2 Is Nothing Then
        Set N2 = A.Cells.Find("G-Code")
    End If

    If Not N2 Is Nothing Then
        i1 = N2.row + 1
        R1 = 7
        Do While i1 <= A.Cells(A.Rows.Count, N2.Column).End(xlUp).row And R1 <= 7 + MR
            B.Cells(R1, C2).Value = A.Cells(i1, N2.Column).Value
            R1 = R1 + 1
            i1 = i1 + 1
        Loop
    End If

    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"


    Set N3 = A.Rows("1:99").Find("P-Code")
    If N3 Is Nothing Then
        Set N3 = A.Rows("1:99").Find("P Code")
    End If

    If Not N3 Is Nothing Then
        i2 = N3.row + 1
        R1 = 7
        Do While i2 <= A.Cells(A.Rows.Count, N3.Column).End(xlUp).row And R1 <= 7 + MR
            B.Cells(R1, C3).Value = A.Cells(i2, N3.Column).Value
            R1 = R1 + 1
            i2 = i2 + 1
        Loop
    End If

    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"


    Set N4 = A.Cells.Find("Func*Name")
    If Not N4 Is Nothing Then
        i3 = N4.row + 1
        R1 = 7
        Do While i3 <= A.Cells(A.Rows.Count, N4.Column).End(xlUp).row And R1 <= 7 + MR
            B.Cells(R1, C4).Value = A.Cells(i3, N4.Column).Value
            R1 = R1 + 1
            i3 = i3 + 1
        Loop
    End If

    Set N5 = A.Rows("1:99").Find("Part No*")
    If N5 Is Nothing Then
        Set N5 = A.Rows("1:99").Find("Loca*", LookIn:=xlValues)
        If Not N5 Is Nothing Then
            Set N5 = A.Cells.Find("Part*Location")
        End If
    End If

    If Not N5 Is Nothing Then
        i4 = N5.row + 1
        R1 = 7
        Do While i4 <= A.Cells(A.Rows.Count, N5.Column).End(xlUp).row And R1 <= 7 + MR
            B.Cells(R1, C5).Value = A.Cells(i4, N5.Column).Value
            R1 = R1 + 1
            i4 = i4 + 1
        Loop
    End If

    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"

    Dim strippedValue As String
    Dim sortedValue As String


    On Error Resume Next
    Set dict = CreateObject("Scripting.Dictionary")
    Set CR1 = B.Range("E7:E500").SpecialCells(xlCellTypeConstants)
    Set CR2 = B.Range("G7:G500").SpecialCells(xlCellTypeConstants)
    Set cr3 = B.Range("H7:H500").SpecialCells(xlCellTypeConstants)
    Set PR1 = C.UsedRange.Columns("A:M").SpecialCells(xlCellTypeConstants)

If Not CR1 Is Nothing And Not PR1 Is Nothing Then
    For Each cell In PR1
        If Not dict.exists(cell.Value) Then
            dict.Add cell.Value, 1
        End If
    Next

    For Each cell In CR1
        If cell.Value Like "PM903347*" Or cell.Value Like "PM9S0002H01A" Or cell.Value Like "PM9M0001X*" Or cell.Value Like "PM9M0001W0*" Or cell.Value Like "PM9S0001X0*" Or cell.Value Like "PM9M0001Y01*" Or cell.Value Like "PM9M0001U*" Or cell.Value Like "PM9M0001V*" Or cell.Value Like "PM90359740*" Or cell.Value Like "PM9M0003*" Or cell.Value Like "PM9035975*" Or cell.Value Like "PM9M0001901*" Then
            cell.Interior.Color = RGB(128, 128, 128)
        ElseIf dict.exists(cell.Value) Then
            cell.Interior.Color = Nothing
        Else
            cell.Interior.Color = vbRed
        End If
    Next
End If



    For Each cell In PR1
        strippedValue = Replace(cell.Value, ",", " ")
        sortedValue = SortComponents(strippedValue)
        'Debug.Print "PR1 value: " & cell.Value & " Sorted: " & sortedValue
        If Not dict.exists(sortedValue) Then
            dict.Add sortedValue, 1
        End If
    Next

    For Each cell In cr3
        strippedValue = Replace(cell.Value, ",", " ")
        sortedValue = SortComponents(strippedValue)
        'Debug.Print "CR3 value: " & cell.Value & " Sorted: " & sortedValue
        If Not dict1.exists(sortedValue) Then
            dict1.Add sortedValue, 1
        End If
    Next

    For Each cell In cr3
        strippedValue = Replace(cell.Value, ",", " ")
        sortedValue = SortComponents(strippedValue)
        If dict.exists(sortedValue) Then
            cell.Interior.Color = vbWhite
        Else
            cell.Interior.Color = vbRed
        End If
    Next


   If Not CR2 Is Nothing And Not PR1 Is Nothing Then
        For Each cell In PR1
            If Not dict.exists(cell.Value) Then
                dict.Add cell.Value, 1
            End If
        Next

        For Each cell In CR2
            If cell.Value Like "8LY*" Or cell.Value Like "MCF*" Or cell.Value Like "MBA*" Or cell.Value Like "8V**" Or cell.Value Like "MVS*" Or cell.Value Like "LABEL-18X19" Or cell.Value Like "MCB0*" Then
            cell.Interior.Color = RGB(128, 128, 128)
            ElseIf dict.exists(cell.Value) Then
                cell.Interior.Color = Nothing
            Else
                cell.Interior.Color = vbRed
            End If
        Next

        dict.RemoveAll
    End If

    On Error GoTo 0
    dict.RemoveAll

    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"

   For Each cell In B.Range("G7:G" & B.Cells(B.Rows.Count, "G").End(xlUp).row)
        rownumber = cell.row
        If B.Cells(rownumber, "E").Interior.Color = vbRed Or _
           B.Cells(rownumber, "G").Interior.Color = vbRed Or _
           B.Cells(rownumber, "H").Interior.Color = vbRed Then
                B.Cells(rownumber, "I").Interior.Color = vbRed
                B.Cells(rownumber, "i").Value = "Not found in 84KIC"
        ElseIf B.Cells(rownumber, "E").Interior.Color = vbWhite Or _
           B.Cells(rownumber, "G").Interior.Color = vbGreen Or _
           B.Cells(rownumber, "H").Interior.Color = vbGreen Then
                B.Cells(rownumber, "I").Interior.Color = vbWhite
                B.Cells(rownumber, "i").Value = "OK"
        End If
    Next
         Set rgba = B.Range("J7:J" & B.Cells(B.Rows.Count, 7).End(xlUp).row)
        rgba.Formula = "=IFERROR(IF(OR(K7=""TZ"", K7=""Kim"", K7=""Tani"", K7=""Austin"", K7=""Abhi"", K7=""Erik"", K7=""Joel"", K7=""Dominic"", K7=""Chris"", K7=""Palmmy"", K7=""Elf"", K7=""Por""), ""OK"", I7), """")"
    For Each cell In B.Range("G7:G" & B.Cells(B.Rows.Count, "G").End(xlUp).row)
        rownumber = cell.row
        If B.Cells(rownumber, "J").Value = "Not found in 84KIC" Then
                B.Cells(rownumber, "J").Interior.Color = vbRed
        End If

    Next

        Set N5 = A.Rows("1:99").Find("Part No*")
    If N5 Is Nothing Then
        Set N5 = A.Rows("1:99").Find("Loca*", LookIn:=xlValues)
        If Not N5 Is Nothing Then
            Set N5 = A.Cells.Find("Part*Location")
        End If
    End If

    If Not N5 Is Nothing Then
        i4 = N5.row + 1
        R1 = 7
        Do While i4 <= A.Cells(A.Rows.Count, N5.Column).End(xlUp).row And R1 <= 7 + MR
            B.Cells(R1, C5).Value = A.Cells(i4, N5.Column).Value
            R1 = R1 + 1
            i4 = i4 + 1
        Loop
    End If
    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: " & (cs / ts) * 100 & "%"

    v = Array("RIBBON*", "Tray*", "*bag*", "Paper*", "*carton*", "*shipping*", "*tape*", "tenta*", "Thermal*")
    lr = B.Cells(B.Rows.Count, 7).End(xlUp).row

    nr = lr + 5

     With B.Cells(nr - 1, 5)
        .Value = "THESE BELOW YELLOW HIGHLIGHT COME OUT FROM 84KIC, PLEASE CHECK IT BY MANUALLY!!"
        .Font.Bold = True
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Color = RGB(0, 0, 255)
        .Font.Size = 16
        .Font.Italic = True
    End With

    For Each Value In v
        For Each cell In C.UsedRange
            If UCase(cell.Value) Like UCase(Value) Then
                B.Cells(nr, 7).Value = cell.Value
                B.Cells(nr, 5).Value = C.Cells(cell.row, 7).Value
                B.Cells(nr, 6).Value = C.Cells(cell.row, 2).Value
                B.Cells(nr, 7).Interior.Color = RGB(255, 255, 0)
                B.Cells(nr, 6).Interior.Color = RGB(255, 255, 0)
                B.Cells(nr, 5).Interior.Color = RGB(255, 255, 0)

                nr = nr + 1
            End If
        Next
    Next
    cs = cs + 1
    B.Cells(1, 3).Value = "Progress: 100%"

    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
          Application.EnableEvents = True
End Sub

Function SortComponents(inputString As String) As String
    Dim arr() As String
    Dim i As Integer
    Dim j As Integer
    Dim temp As String


    arr = Split(Replace(inputString, ",", " "), " ")

     For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If CompareComponents(Trim(arr(i)), Trim(arr(j))) > 0 Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i

     SortComponents = Join(arr, " ")
End Function

Function CompareComponents(comp1 As String, comp2 As String) As Integer
     Dim num1 As Double
    Dim num2 As Double

    On Error Resume Next
    num1 = CDbl(Replace(comp1, "C", ""))
    num2 = CDbl(Replace(comp2, "C", ""))
    On Error GoTo 0

    If num1 = num2 Then
        CompareComponents = StrComp(comp1, comp2, vbTextCompare)
    ElseIf IsNumeric(num1) And IsNumeric(num2) Then
        If num1 < num2 Then
            CompareComponents = -1
        Else
            CompareComponents = 1
        End If
    Else
        CompareComponents = StrComp(comp1, comp2, vbTextCompare)
    End If

End Function

Sub Cleardata()

Call C1
Call C2
Call C3

End Sub

Sub C1()

shData.Cells.Clear

End Sub

Sub C2()
    Application.EnableEvents = False
    npidata.Rows("7:70000").Delete
        Application.EnableEvents = True
End Sub

Sub C3()
    Sheet1.Cells.Clear

End Sub