Как вы форматируете и объединяете счет-фактуру или банковскую выписку с различными диапазонами в VBA

Question

У меня есть счет от поставщика услуг, который мне нужно отформатировать, чтобы я мог использовать данные в Excel. Но форматирование не соответствует.

Существует три (3) столбца:

1. ID
2. Описание
3. Сумма

Многие идентификаторы # в счете имеют описание в одну строку (строку).

Но у многих есть 2-11 строк (строк) описания.

Идентификатор # указывается только один раз с каждым набором строк описания.

До этого момента я использовал формулы Excel. Но все мои формулы делают вещи go очень медленными.

VBA будет намного быстрее.

Я создал систему индексов, которая ищет новые идентификаторы.

Затем я создал каскадную каскадную формулу на основе заданной системы индексов.

Сумму легко вывести с помощью формулы LEFT, так как сумма указана в долларах США.

Затем у меня есть второй лист, который делает VLOOKUP от первого листа, чтобы получить идентификаторы, окончательные составные описания и суммы.

В нашем последнем счете было 17 427 строк данных с только 1717 ID # s.

Вот пример того, с чем я работаю:

Я хочу, чтобы это выглядело как это:

Answer 1

одно из возможных решений ниже:

'assume that Id in column `A`, Description in column `B`, Amount in `C` and header in row 1
Sub somecode()

    Dim wb As Workbook: Set wb = ActiveWorkbook
    Dim sh As Worksheet: Set sh = wb.ActiveSheet

    Dim lastRow&: lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
    Dim idColumn As Range: Set idColumn = sh.Range("A1:A" & lastRow)
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")

    Dim cl As Range, keyID, valueDescription$, valueAmount$

    For Each cl In idColumn
        If cl.Value <> "" And Not dic.exists(cl.Value) Then
            dic.Add cl.Value, sh.Cells(cl.Row, "B").Value & "|" & sh.Cells(cl.Row, "C").Value
            keyID = cl.Value
            valueDescription = sh.Cells(cl.Row, "B").Value
            valueAmount = sh.Cells(cl.Row, "C").Value
        ElseIf cl.Value = "" Then
            valueDescription = valueDescription & " " & sh.Cells(cl.Row, "B").Value
            dic(keyID) = valueDescription & "|" & valueAmount
        End If
    Next cl

    Set sh = wb.Sheets.Add: sh.Name = "Result " & Date & " " & Replace(Time(), ":", "-")

    Dim dkey, xRow&: xRow = 1

    For Each dkey In dic

        sh.Cells(xRow, "A").Value = dkey
        sh.Cells(xRow, "B").Value = Split(dic(dkey), "|")(0)
        sh.Cells(xRow, "C").Value = Split(dic(dkey), "|")(1)

        xRow = xRow + 1

    Next dkey

    sh.Columns("A:C").AutoFit

End Sub

тест:

Answer 2

Я написал код для вас, чтобы сделать эту работу. Пожалуйста, установите его в стандартный модуль кода. Это тот, который вы должны вставить. Ни один из существующих не подходит.

Option Explicit

Enum Nws                        ' Worksheet setup (set values as required)
    NwsFirstDataRow = 2
    NwsNumColumns = 8           ' total number of columns in the sheet
    NwsID = 1                   ' Columns: 1 = column A
    NwsDesc                     '          undefined = previous + 1
    NwsAmt = 5                  '          5 = column E
End Enum

Sub MergeRows()
    ' Variatus @STO 24 Jan 2020

    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim RowArr As Variant
    Dim Desc As String, Amt As Double
    Dim Tmp As Variant
    Dim R As Long

    ' define workbook and worksheet as required
    Set Wb = ActiveWorkbook                     ' this need not be ThisWorkbook
    Set Ws = Wb.Worksheets("Invoice")           ' change as appropriate

    Application.ScreenUpdating = False
    With Ws
        R = .Cells(.Rows.Count, NwsDesc).End(xlUp).Row
        For R = R To NwsFirstDataRow Step -1
            If (R Mod 25) = 3 Then 'NwsFirstDataRow Then
                Application.StatusBar = "Another " & R & " rows to process."
            End If

            Tmp = Trim(.Cells(R, NwsID).Value)
            If Len(Tmp) Then
                Set Rng = Range(.Cells(R, 1), .Cells(R, NwsNumColumns))
                RowArr = Rng.Value
                RowArr(1, NwsAmt) = TextToAmount(RowArr(1, NwsAmt))
                If Len(Desc) Then
                    ' if you want a comma instead of a line break
                    ' replace Chr(10) with "," in the next line:-
                    RowArr(1, NwsDesc) = RowArr(1, NwsDesc) & Chr(10) & Desc
                    RowArr(1, NwsAmt) = RowArr(1, NwsAmt) + Amt
                    Desc = ""
                    Amt = 0
                End If

                With Rng
                    .Value = RowArr
                    .Cells.VerticalAlignment = xlTop
                    .Cells(NwsAmt).NumberFormat = "$#,##0.00"
                End With
                .Rows(R).AutoFit
            Else
                Tmp = Trim(.Cells(R, NwsDesc).Value)
                If Len(Desc) Then Desc = Chr(10) & Desc
                Desc = Tmp & Desc
                Tmp = TextToAmount(.Cells(R, NwsAmt).Value)
                If Tmp Then Amt = Amt + Tmp
                .Rows(R).EntireRow.Delete
            End If
        Next R
    End With

    With Application
        .ScreenUpdating = True
        .StatusBar = "Done"
    End With
End Sub

Private Function TextToAmount(ByVal Amt As Variant) As Double

    Dim Tmp As Variant

    Tmp = Trim(Amt)
    If Len(Tmp) Then Tmp = Mid(Tmp, InStr(Tmp, "$") + 1)
    TextToAmount = Val(Tmp)
End Function

Прежде чем вы сможете его запустить, вам нужно установить перечисления в верхней части, чтобы сообщить коду, где находятся ваши данные и столбцы. С той же целью, пожалуйста, установите переменные для рабочей книги (Wb) и рабочей таблицы (Ws) в самой процедуре.

Обратите внимание, что код добавляет цену, если она есть, в строки, которые удаляются, к сумме. установить против оставшегося элемента.

Наконец, вы увидите, что я запрограммировал различные строки, чтобы они стали линиями в одной ячейке. Это не то, что вы просили. Если вы хотите, чтобы элементы разделялись запятыми, найдите в коде примечание, в котором вы можете изменить это.