Option Explicit

Const KIZ_LEN = 31   ' КИЗ без криптохвоста: "01" + GTIN (14) + "21" + серийный номер (13)

' ============================================================
' xlsx/xls/xlsm: сопоставление отсканированных КИЗ с товарной
' накладной + экспорт CSV (UTF-8, разделитель - запятая,
' последняя колонка в двойных кавычках, если в ней есть запятая)
' Windows 7 + Excel 2007/2010/2013/2016
'
' Что делает:
'   1. Спрашивает два файла (окна выбора; файл КИЗ можно также
'      перетащить на скрипт):
'      файл 1 - товарная накладная (ТОРГ-12),
'      файл 2 - таблица с отсканированными КИЗ (последняя
'      заполненная колонка - коды DataMatrix).
'   2. Из каждого КИЗ извлекает GTIN (DataMatrix: "01" + 14 цифр).
'   3. Ищет GTIN в колонке B ("Наименование") накладной, начиная с ряда 19:
'      GTIN - последнее "слово" значения (текст после последнего пробела).
'   4. Из найденного ряда накладной берет:
'      название  - колонка B, текст до последнего пробела,
'      цена      - колонка L,
'      ставка НДС - колонка N (вписывается со знаком %).
'   5. Вписывает в файл 2 напротив КИЗ:
'      B - название, C - цена, D - 1, E - 796, F - ставка НДС (%),
'      G - "КИЗ". Колонки B, C, F получают текстовый формат,
'      никаких преобразований чисел Excel не делает.
'      КИЗ в CSV обрезается до первых 31 символа (код без криптохвоста);
'      более короткий КИЗ остается как есть, с замечанием в отчете.
'   6. Сверяет: число КИЗ каждого GTIN в файле 2 должно совпадать
'      с количеством из колонки K накладной.
'   7. Сохраняет CSV рядом с файлом 2 (то же имя, .csv) и показывает
'      отчет о сверке. Сам файл 2 на диске не изменяется.
' ============================================================

Dim fso, excelApp
Dim fileKiz, fileNakl, csvPath, reportPath
Dim wb1, ws1, ur1, lastRow1
Dim wb2, ws2, ur2, firstRow2, nRows2, lastCol2
Dim r, c, v, s, gtin, key, rowNakl
Dim name1, price1, vat1, i
Dim dictRow, dictQty, dictFound, dictShow, dictKiz
Dim kizTotal, kizMatched
Dim warnText, okText
Dim out, line

Set fso = CreateObject("Scripting.FileSystemObject")

Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = False
excelApp.DisplayAlerts = False
excelApp.ScreenUpdating = False
excelApp.EnableEvents = False

' --- выбор файлов ---
fileKiz = ""
If WScript.Arguments.Count > 0 Then
    If fso.FileExists(WScript.Arguments(0)) Then fileKiz = WScript.Arguments(0)
End If
If fileKiz = "" Then
    fileKiz = PickFile("Выберите файл 2 - таблица с отсканированными КИЗ")
    If fileKiz = "" Then CleanQuit
End If

fileNakl = PickFile("Выберите файл 1 - товарная накладная (ТОРГ-12)")
If fileNakl = "" Then CleanQuit

Set dictRow  = CreateObject("Scripting.Dictionary")  ' key GTIN -> ряд накладной
Set dictQty  = CreateObject("Scripting.Dictionary")  ' key GTIN -> количество (K)
Set dictFound = CreateObject("Scripting.Dictionary") ' key GTIN -> число КИЗ в файле 2
Set dictShow  = CreateObject("Scripting.Dictionary") ' key GTIN -> GTIN для показа
Set dictKiz   = CreateObject("Scripting.Dictionary") ' ряд файла 2 -> КИЗ без криптохвоста

' --- файл 1: накладная (только чтение, держим открытой до конца обработки) ---
Set wb1 = excelApp.Workbooks.Open(fileNakl, 0, True)
Set ws1 = wb1.Worksheets(1)
Set ur1 = ws1.UsedRange
lastRow1 = ur1.Row + ur1.Rows.Count - 1

Dim gtinB

For r = 19 To lastRow1
    gtinB = GtinFromName(ws1.Cells(r, 2).Value)   ' колонка B - "Наименование", GTIN после последнего пробела
    key = NormGtin(gtinB)
    If Len(key) >= 8 Then
        If Not dictRow.Exists(key) Then
            dictRow.Add key, r
            If IsNumeric(ws1.Cells(r, 11).Value) Then   ' колонка K - количество
                dictQty.Add key, CDbl(ws1.Cells(r, 11).Value)
            End If
        End If
    End If
Next

If dictRow.Count = 0 Then
    MsgBox "В колонке B (" & Chr(34) & "Наименование" & Chr(34) & ") накладной, начиная с ряда 19," & vbCrLf & _
           "не найдено ни одного GTIN (код после последнего пробела)." & vbCrLf & vbCrLf & _
           "Проверьте, что это файл товарной накладной.", vbExclamation, "Сопоставление КИЗ"
    CleanQuit
End If

' --- файл 2: таблица с КИЗ ---
Set wb2 = excelApp.Workbooks.Open(fileKiz)
Set ws2 = wb2.Worksheets(1)
Set ur2 = ws2.UsedRange
firstRow2 = ur2.Row
nRows2 = ur2.Rows.Count
lastCol2 = ur2.Column + ur2.Columns.Count - 1          ' абсолютный номер последней колонки (КИЗ)

kizTotal = 0
kizMatched = 0
warnText = ""

For r = 1 To nRows2
    v = ws2.Cells(firstRow2 + r - 1, lastCol2).Value
    s = CleanText(v)
    If s <> "" Then
        gtin = ExtractGTIN(s)
        If gtin = "" Then
            warnText = warnText & "Ряд " & (firstRow2 + r - 1) & ": не удалось извлечь GTIN из кода КИЗ." & vbCrLf
        Else
            kizTotal = kizTotal + 1
            dictKiz.Add firstRow2 + r - 1, Left(s, KIZ_LEN)
            If Len(s) < KIZ_LEN Then
                warnText = warnText & "Ряд " & (firstRow2 + r - 1) & ": КИЗ короче " & KIZ_LEN & _
                           " символов (" & Len(s) & "), записан как есть." & vbCrLf
            End If
            key = NormGtin(gtin)
            If Not dictFound.Exists(key) Then
                dictFound.Add key, 0
                dictShow.Add key, gtin
            End If
            dictFound(key) = dictFound(key) + 1

            If dictRow.Exists(key) Then
                rowNakl = dictRow(key)

                ' --- название: колонка B накладной, текст до последнего пробела ---
                s = CleanText(ws1.Cells(rowNakl, 2).Value)
                name1 = ""
                i = InStrRev(s, " ")
                If i > 0 Then name1 = Trim(Left(s, i - 1))

                ' --- цена: колонка L ---
                price1 = NumText(ws1.Cells(rowNakl, 12).Value)

                ' --- ставка НДС: колонка N, обязательно со знаком % ---
                s = NumText(ws1.Cells(rowNakl, 14).Value)
                If s <> "" Then
                    If Right(s, 1) <> "%" Then s = s & "%"
                End If
                vat1 = s

                ' --- вписываем в файл 2 (B, C, F - текстовый формат) ---
                With ws2
                    .Cells(firstRow2 + r - 1, 2).NumberFormat = "@"
                    .Cells(firstRow2 + r - 1, 2).Value = CStr(name1)
                    .Cells(firstRow2 + r - 1, 3).NumberFormat = "@"
                    .Cells(firstRow2 + r - 1, 3).Value = CStr(price1)
                    .Cells(firstRow2 + r - 1, 4).Value = 1
                    .Cells(firstRow2 + r - 1, 5).Value = 796
                    .Cells(firstRow2 + r - 1, 6).NumberFormat = "@"
                    .Cells(firstRow2 + r - 1, 6).Value = CStr(vat1)
                    .Cells(firstRow2 + r - 1, 7).Value = "КИЗ"
                End With
                kizMatched = kizMatched + 1
            Else
                warnText = warnText & "Ряд " & (firstRow2 + r - 1) & ": GTIN " & gtin & _
                           " не найден в колонке B накладной (ряды с 19)." & vbCrLf
            End If
        End If
    End If
Next

wb1.Close False

' --- сверка количества: файл 2 vs колонка K накладной ---
okText = ""
For Each key In dictFound
    If dictRow.Exists(key) Then
        If dictQty.Exists(key) Then
            If CLng(dictQty(key)) = CLng(dictFound(key)) Then
                okText = okText & "GTIN " & dictShow(key) & ": " & dictFound(key) & _
                         " шт. = накладной (K) " & CStr(dictQty(key)) & "  - OK" & vbCrLf
            Else
                warnText = warnText & "GTIN " & dictShow(key) & ": КИЗ в файле " & dictFound(key) & _
                         " шт., в накладной (K) " & CStr(dictQty(key)) & "  - НЕ СОВПАДАЕТ" & vbCrLf
            End If
        Else
            warnText = warnText & "GTIN " & dictShow(key) & ": в ряде накладной не указано количество (K)." & vbCrLf
        End If
    End If
Next

' --- экспорт CSV (UTF-8; последняя колонка в кавычках при наличии запятой) ---
out = ""
For r = 1 To nRows2
    line = ""
    For c = 1 To lastCol2
        v = ws2.Cells(firstRow2 + r - 1, c).Value
        If c = lastCol2 Then
            Dim lastField
            If dictKiz.Exists(firstRow2 + r - 1) Then
                lastField = dictKiz(firstRow2 + r - 1)   ' КИЗ без криптохвоста
            Else
                lastField = FormatField(v)
            End If
            If InStr(lastField, ",") > 0 Then
                line = line & """" & Replace(lastField, """", """""") & """"
            Else
                line = line & lastField
            End If
        Else
            line = line & FormatField(v)
        End If
        If c < lastCol2 Then line = line & ","
    Next
    If r < nRows2 Then
        out = out & line & vbCrLf
    Else
        out = out & line
    End If
Next

csvPath = fso.GetParentFolderName(fileKiz) & "\" & fso.GetBaseName(fileKiz) & ".csv"
reportPath = fso.GetParentFolderName(fileKiz) & "\" & fso.GetBaseName(fileKiz) & "_report.txt"

WriteUtf8 csvPath, out
WriteUtf8 reportPath, "Отчет сопоставления КИЗ" & vbCrLf & _
                      "Накладная: " & fileNakl & vbCrLf & _
                      "Файл КИЗ: " & fileKiz & vbCrLf & vbCrLf & _
                      "Обработано КИЗ: " & kizTotal & ", сопоставлено: " & kizMatched & vbCrLf & vbCrLf & _
                      "Сверка количества (файл КИЗ vs колонка K накладной):" & vbCrLf & okText & vbCrLf & _
                      "Замечания:" & vbCrLf & warnText

wb2.Close False   ' файл 2 на диске не изменяем

' --- итоговое окно ---
If warnText = "" Then
    MsgBox "Готово. Обработано КИЗ: " & kizTotal & ", сопоставлено: " & kizMatched & "." & vbCrLf & _
           "Все количества совпали с накладной." & vbCrLf & vbCrLf & _
           "CSV: " & csvPath, vbInformation, "Сопоставление КИЗ"
Else
    MsgBox "Готово, но есть замечания (подробности в отчете):" & vbCrLf & reportPath & vbCrLf & vbCrLf & _
           "Обработано КИЗ: " & kizTotal & ", сопоставлено: " & kizMatched & ".", vbExclamation, "Сопоставление КИЗ"
End If

CleanQuit

' ============================================================
' Функции
' ============================================================

Function PickFile(title)
    Dim res
    res = excelApp.GetOpenFilename( _
        "Excel файлы (*.xlsx;*.xls;*.xlsm),*.xlsx;*.xls;*.xlsm", 1, title)
    If VarType(res) = vbBoolean Then
        PickFile = ""
    Else
        PickFile = CStr(res)
    End If
End Function

Function CleanText(v)
    Dim t
    t = CStr(v)
    t = Replace(t, vbCr, "")
    t = Replace(t, vbLf, "")
    CleanText = Trim(t)
End Function

' Из DataMatrix-строки КИЗ извлекает GTIN: "01" + 14 цифр
Function ExtractGTIN(s)
    Dim t
    t = Replace(s, " ", "")
    If Len(t) >= 16 Then
        If Left(t, 2) = "01" Then
            If IsNumeric(Mid(t, 3, 14)) Then
                ExtractGTIN = Mid(t, 3, 14)
                Exit Function
            End If
        End If
    End If
    ExtractGTIN = ""
End Function

' Из колонки B накладной ("Наименование ... GTIN") извлекает GTIN:
' текст после последнего пробела, только цифры
Function GtinFromName(v)
    Dim t, i
    t = CleanText(v)
    i = InStrRev(t, " ")
    If i > 0 Then
        GtinFromName = DigitsOnly(Mid(t, i + 1))
    Else
        GtinFromName = DigitsOnly(t)
    End If
End Function

' Оставляет только цифры; числовые ячейки читает без экспоненты
Function DigitsOnly(v)
    Dim t, ch, res
    res = ""
    If VarType(v) <> 8 And IsNumeric(v) Then
        t = FormatNumber(CDbl(v), 0, vbFalse, vbFalse, vbFalse)
    Else
        t = CStr(v)
    End If
    For i = 1 To Len(t)
        ch = Mid(t, i, 1)
        If ch >= "0" And ch <= "9" Then res = res & ch
    Next
    DigitsOnly = res
End Function

' Убирает ведущие нули для сравнения (GTIN может храниться как 14-значный
' код с нулем или как 13-значное число без него)
Function NormGtin(g)
    Dim t
    t = g
    Do While Left(t, 1) = "0" And Len(t) > 1
        t = Mid(t, 2)
    Loop
    NormGtin = t
End Function

' Число как текст с точкой в десятичной части (358.18, а не 358,18)
Function NumText(v)
    Dim t
    If IsNumeric(v) Then
        t = CStr(CDbl(v))
        t = Replace(t, ",", ".")
        If Right(t, 2) = ".0" Then t = Left(t, Len(t) - 2)   ' 10.0 -> 10
        NumText = t
    Else
        t = Trim(CStr(v))
        If Right(t, 1) = "%" Then t = Left(t, Len(t) - 1)
        NumText = t
    End If
End Function

Function FormatField(v)
    Dim t
    Select Case VarType(v)
        Case 0, 1            ' vbEmpty, vbNull
            FormatField = ""
        Case 2, 3, 4, 5, 6   ' числа: точка как разделитель
            t = CStr(CDbl(v))
            FormatField = Replace(t, ",", ".")
        Case Else            ' текст как есть
            FormatField = CStr(v)
    End Select
End Function

Sub WriteUtf8(path, text)
    Dim st
    Set st = CreateObject("ADODB.Stream")
    st.Type = 2
    st.Charset = "utf-8"
    st.Open
    st.WriteText text
    st.SaveToFile path, 2
    st.Close
End Sub

Sub CleanQuit
    On Error Resume Next
    wb2.Close False
    wb1.Close False
    excelApp.Quit
    WScript.Quit
End Sub