Центр помощи БАРЛАЙВ

Изменения

Внутреннее:Модуль Бухгалтера БАРЛАЙВ (посмотреть исходный код)

Версия от 20:28, 20 июля 2026

8648 байт добавлено ,  20 июль
→‎Акты списания
Строка 715: Строка 715:     
Ошибки как правило сразу видны внутри акта в шапке в "Ответах в тикете"; и можно подробнее посмотреть ниже в "Запросах" что именно целиком прислал ЕГАИС.
 
Ошибки как правило сразу видны внутри акта в шапке в "Ответах в тикете"; и можно подробнее посмотреть ниже в "Запросах" что именно целиком прислал ЕГАИС.
 +
 +
===Схлопнуть марки в выгруженном списке из акта===
 +
 +
Сейчас в "Актах списания" ШК может повторяться в нескольких строках с разным объёмом - для сохранения истории добавлений; если же требуется вычислить общий объём таких ШК в акте, то надо зайти во вкладку "Марки", выгрузить xlsx файл, затем использовать макрос для суммирования.
 +
 +
Макрос:
 +
 +
<pre>
 +
Option Explicit
 +
 +
Sub СхлопнутьМаркиИСуммироватьОбъем()
 +
 +
    Const HEADER_ROW As Long = 1
 +
    Const RESULT_SHEET_NAME As String = "Схлопнутые марки"
 +
 +
    Dim sourceSheet As Worksheet
 +
    Dim resultSheet As Worksheet
 +
 +
    Dim markColumn As Long
 +
    Dim volumeColumn As Long
 +
    Dim lastRow As Long
 +
    Dim lastColumn As Long
 +
 +
    Dim sourceData As Variant
 +
    Dim resultData() As Variant
 +
 +
    Dim dictionary As Object
 +
    Dim rowIndexes As Object
 +
 +
    Dim rowNumber As Long
 +
    Dim columnNumber As Long
 +
    Dim resultRow As Long
 +
 +
    Dim markValue As String
 +
    Dim volumeValue As Double
 +
    Dim dictionaryKey As Variant
 +
 +
    On Error GoTo ErrorHandler
 +
 +
    Application.ScreenUpdating = False
 +
    Application.EnableEvents = False
 +
    Application.DisplayAlerts = False
 +
 +
    Set sourceSheet = ActiveSheet
 +
 +
    ' Определяем границы таблицы
 +
    lastRow = sourceSheet.Cells( _
 +
        sourceSheet.Rows.Count, 1 _
 +
    ).End(xlUp).Row
 +
 +
    lastColumn = sourceSheet.Cells( _
 +
        HEADER_ROW, sourceSheet.Columns.Count _
 +
    ).End(xlToLeft).Column
 +
 +
    ' Ищем нужные столбцы по названиям
 +
    For columnNumber = 1 To lastColumn
 +
 +
        Select Case Trim$(CStr(sourceSheet.Cells( _
 +
            HEADER_ROW, columnNumber _
 +
        ).Value))
 +
 +
            Case "Марка"
 +
                markColumn = columnNumber
 +
 +
            Case "Объем (мл)"
 +
                volumeColumn = columnNumber
 +
 +
        End Select
 +
 +
    Next columnNumber
 +
 +
    If markColumn = 0 Then
 +
        Err.Raise vbObjectError + 1, , _
 +
            "Не найден столбец «Марка»."
 +
    End If
 +
 +
    If volumeColumn = 0 Then
 +
        Err.Raise vbObjectError + 2, , _
 +
            "Не найден столбец «Объем (мл)»."
 +
    End If
 +
 +
    If lastRow <= HEADER_ROW Then
 +
        Err.Raise vbObjectError + 3, , _
 +
            "В таблице отсутствуют строки с данными."
 +
    End If
 +
 +
    ' Загружаем таблицу в память
 +
    sourceData = sourceSheet.Range( _
 +
        sourceSheet.Cells(HEADER_ROW, 1), _
 +
        sourceSheet.Cells(lastRow, lastColumn) _
 +
    ).Value2
 +
 +
    Set dictionary = CreateObject("Scripting.Dictionary")
 +
    Set rowIndexes = CreateObject("Scripting.Dictionary")
 +
 +
    ' Марки сравниваются целиком, с учётом регистра
 +
    dictionary.CompareMode = vbBinaryCompare
 +
    rowIndexes.CompareMode = vbBinaryCompare
 +
 +
    ' Сначала собираем суммы
 +
    For rowNumber = 2 To UBound(sourceData, 1)
 +
 +
        markValue = Trim$(CStr(sourceData( _
 +
            rowNumber, markColumn _
 +
        )))
 +
 +
        If Len(markValue) > 0 Then
 +
 +
            volumeValue = GetNumericVolume( _
 +
                sourceData(rowNumber, volumeColumn) _
 +
            )
 +
 +
            If dictionary.Exists(markValue) Then
 +
 +
                dictionary(markValue) = _
 +
                    CDbl(dictionary(markValue)) + volumeValue
 +
 +
            Else
 +
 +
                dictionary.Add markValue, volumeValue
 +
                rowIndexes.Add markValue, rowNumber
 +
 +
            End If
 +
 +
        End If
 +
 +
    Next rowNumber
 +
 +
    If dictionary.Count = 0 Then
 +
        Err.Raise vbObjectError + 4, , _
 +
            "В столбце «Марка» нет заполненных значений."
 +
    End If
 +
 +
    ' Формируем итоговый массив:
 +
    ' заголовок + одна строка на каждую уникальную марку
 +
    ReDim resultData( _
 +
        1 To dictionary.Count + 1, _
 +
        1 To lastColumn _
 +
    )
 +
 +
    ' Копируем заголовки
 +
    For columnNumber = 1 To lastColumn
 +
        resultData(1, columnNumber) = _
 +
            sourceData(1, columnNumber)
 +
    Next columnNumber
 +
 +
    resultRow = 2
 +
 +
    For Each dictionaryKey In dictionary.Keys
 +
 +
        rowNumber = CLng(rowIndexes(dictionaryKey))
 +
 +
        ' Берём остальные поля из первой строки марки
 +
        For columnNumber = 1 To lastColumn
 +
            resultData(resultRow, columnNumber) = _
 +
                sourceData(rowNumber, columnNumber)
 +
        Next columnNumber
 +
 +
        ' Записываем точную марку и объединённый объём
 +
        resultData(resultRow, markColumn) = _
 +
            CStr(dictionaryKey)
 +
 +
        resultData(resultRow, volumeColumn) = _
 +
            CDbl(dictionary(dictionaryKey))
 +
 +
        resultRow = resultRow + 1
 +
 +
    Next dictionaryKey
 +
 +
    ' Удаляем старый лист с результатом, если он есть
 +
    On Error Resume Next
 +
    ThisWorkbook.Worksheets(RESULT_SHEET_NAME).Delete
 +
    On Error GoTo ErrorHandler
 +
 +
    ' Создаём новый лист
 +
    Set resultSheet = ThisWorkbook.Worksheets.Add( _
 +
        After:=sourceSheet _
 +
    )
 +
 +
    resultSheet.Name = RESULT_SHEET_NAME
 +
 +
    ' Записываем результат
 +
    resultSheet.Range( _
 +
        resultSheet.Cells(1, 1), _
 +
        resultSheet.Cells(UBound(resultData, 1), lastColumn) _
 +
    ).Value = resultData
 +
 +
    ' Переносим ширину и формат столбцов
 +
    For columnNumber = 1 To lastColumn
 +
 +
        resultSheet.Columns(columnNumber).ColumnWidth = _
 +
            sourceSheet.Columns(columnNumber).ColumnWidth
 +
 +
        resultSheet.Columns(columnNumber).NumberFormat = _
 +
            sourceSheet.Columns(columnNumber).NumberFormat
 +
 +
    Next columnNumber
 +
 +
    ' Оформляем заголовок и фильтр
 +
    With resultSheet.Range( _
 +
        resultSheet.Cells(1, 1), _
 +
        resultSheet.Cells(1, lastColumn) _
 +
    )
 +
        .Font.Bold = True
 +
        .AutoFilter
 +
    End With
 +
 +
    resultSheet.Columns(markColumn).NumberFormat = "@"
 +
    resultSheet.Columns(volumeColumn).NumberFormat = "0.##"
 +
    resultSheet.Rows(1).AutoFit
 +
    resultSheet.Activate
 +
 +
    Application.DisplayAlerts = True
 +
    Application.EnableEvents = True
 +
    Application.ScreenUpdating = True
 +
 +
    MsgBox _
 +
        "Готово." & vbCrLf & _
 +
        "Исходных строк: " & Format$(lastRow - 1, "#,##0") & vbCrLf & _
 +
        "Уникальных марок: " & Format$(dictionary.Count, "#,##0") & vbCrLf & _
 +
        "Результат записан на лист «" & _
 +
        RESULT_SHEET_NAME & "».", _
 +
        vbInformation
 +
 +
    Exit Sub
 +
 +
ErrorHandler:
 +
 +
    Application.DisplayAlerts = True
 +
    Application.EnableEvents = True
 +
    Application.ScreenUpdating = True
 +
 +
    MsgBox _
 +
        "Не удалось обработать таблицу:" & vbCrLf & _
 +
        Err.Description, _
 +
        vbCritical
 +
 +
End Sub
 +
 +
 +
Private Function GetNumericVolume(ByVal cellValue As Variant) As Double
 +
 +
    Dim textValue As String
 +
 +
    If IsError(cellValue) Or IsEmpty(cellValue) Then
 +
        GetNumericVolume = 0
 +
        Exit Function
 +
    End If
 +
 +
    If IsNumeric(cellValue) Then
 +
        GetNumericVolume = CDbl(cellValue)
 +
        Exit Function
 +
    End If
 +
 +
    textValue = Trim$(CStr(cellValue))
 +
    textValue = Replace(textValue, Chr(160), "")
 +
    textValue = Replace(textValue, " ", "")
 +
    textValue = Replace(textValue, ".", _
 +
        Application.DecimalSeparator)
 +
    textValue = Replace(textValue, ",", _
 +
        Application.DecimalSeparator)
 +
 +
    If IsNumeric(textValue) Then
 +
        GetNumericVolume = CDbl(textValue)
 +
    Else
 +
        GetNumericVolume = 0
 +
    End If
 +
 +
End Function
 +
</pre>
 +
 +
Выгружаете список "Марки", затем:
 +
 +
1 - Сохраните файл как «Книга Excel с поддержкой макросов (*.xlsm)».
 +
 +
2 - Нажмите Alt + F11.
 +
 +
3 - Выберите Вставка → Модуль.
 +
 +
4 - Вставьте код макроса (выше).
 +
 +
5 - Вернитесь в Excel.
 +
 +
6 - Откройте исходный лист и нажмите Alt + F8.
 +
 +
7 - Запустите «СхлопнутьМаркиИСуммироватьОбъем».
 +
 +
Будет создан новый лист со "схлопнутыми" марками, где будут суммированные объёмы.
    
===Ошибка в актах списания из-за марок с низким регистром===
 
===Ошибка в актах списания из-за марок с низким регистром===
Источник — https://wiki.barlive.ru/wiki/Служебная:Сравнение_версий/1162