如何在VBA中用不同的范围格式化和连接发票或银行对账单

Question

我有一个服务提供者的发票，我需要格式化，这样我就可以使用Excel中的数据。但是，格式不一致。

有三(3)栏：

1. ID
2. Description
3. Amount

发票上的许多ID#s都有一行(行)描述。

但也有很多人有2-11行描述。

ID#只在每组描述行中列出一次。

到目前为止，我已经使用了Excel公式。但是，我所有的公式都让事情发展得很慢。

VBA会快得多。

我所做的就是创建一个寻找新ID#s的索引系统。

然后，根据给定的指标体系，建立了级联级联公式。

使用LEFT公式提取金额是很容易的，因为金额列出了美元。

然后，我有第二个表，它从第一个表中提取一个VLOOKUP，以提取ID、最终连接的描述和数量。

我们的上一张发票有17,427行数据，只有1,717 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)的变量。

请注意，代码将删除的行中的价格(如果有的话)添加到针对其余项设置的金额中。

最后，您将看到，我编写了不同的行，使其成为单个单元格中的线条。这不是你要的。如果您希望用逗号分隔项目，请在代码中查找注释，在代码中可以更改此注释。