Question

我目前正在尝试制作一个地图，用于转换列中的唯一值，并使用另一个表中的某些参数填充此新列表，

此地图上的结果应为以下内容

我已经拥有了如下唯一值的代码：

Dim d As Object
Dim c As Variant
Dim i As Long
Dim lr As Long

Set d = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 9).End(xlUp).Row
    c = Range("B2:B" & lr)
    For i = 1 To UBound(c, 1)
    d(c(i, 1)) = 1

    Next i
Range("AK2").Resize(d.Count) = Application.Transpose(d.keys)

虽然为填写栏目栏和增值税栏上的金额，我在尝试考虑公式方面存在一些问题，但基本上是为了＃34; Base＆＃34;该值应为以6 *，7 *开头的帐户的凭证Nr的总和，这是Dr - Cr的结果。

我知道这听起来有点令人困惑，但如果有人能帮助我，我将不胜感激。

Answer 1

在评论中使用@RonRosenfeld公式，以下内容可能会有所帮助：

Sub Demo()

    Dim lastRow As Long, lastCol As Long, currLR As Long
    Dim rng As Range, rngWH As Range
    Dim srcSht As Worksheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set srcSht = Sheets("Sheet1")   'set data sheet here
    With srcSht
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row 'last row with data in sheet
        Set rng = .Range("A1:A" & lastRow)                'range for filter
        Set rngWH = .Range("A2:A" & lastRow)              'range for formulas
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2 'column to display data
        rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, lastCol), unique:=True
        currLR = .Cells(.Rows.Count, lastCol).End(xlUp).Row 'unique nr. doc count
        lastCol = lastCol + 1

        'formula for Base
        .Cells(1, lastCol).Value = "Base"
        .Range(.Cells(2, lastCol), .Cells(currLR, lastCol)).Formula = _
            "=SUMPRODUCT((" & .Cells(2, lastCol - 1).Address(False, False) & "=" & rngWH.Address & ")*(LEFT(" & rngWH.Offset(, 1).Address & ")={""6"",""7""})*(" & rngWH.Offset(, 2).Address & "))"

        'formula for Vat
        .Cells(1, lastCol + 1).Value = "VAT"
        'enter formula here for VAT

        'formula for Total
        .Cells(1, lastCol + 2).Value = "Total"
        .Range(.Cells(2, lastCol + 2), .Cells(currLR, lastCol + 2)).Formula = _
            "=SUMIF(" & rngWH.Address & "," & .Cells(2, lastCol - 1).Address(False, False) & "," & rngWH.Offset(, 3).Address & ")"

        .Range(.Cells(2, lastCol), .Cells(currLR, lastCol + 2)).Value = .Range(.Cells(2, lastCol), .Cells(currLR, lastCol + 2)).Value
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

对于纯粹的＆＃34; VBA解决方案，我会

创建一个用户定义的对象，该对象作为Nr.Doc，Acct，VAT，Base和Total的属性。
Base，正如您所写，我们通过检查帐户的第一个数字来检测
增值税将是Dr列中不以6或7开头的任何金额
总计将是Cr列中的值。

如果您的规则不同，通过这样设置，可以轻松更改它们，因为代码几乎可以自我记录。

对于UDO，我们输入一个类模块并将其重命名为cDoc。此外，我选择使用早期绑定，因此我们设置了对Microsoft Scripting Runtime的引用。如果您想像在发布的代码中那样将其更改为延迟绑定，请随意执行此操作。如果您要分发文件，可能会更容易;但我更喜欢在编码时使用Intellisense。

班级单元

Option Explicit
'Rename this module "cDoc"
Private pDocNum As String
Private pAcct As String
Private pBase As Currency
Private pVAT As Currency
Private pTotal As Currency

Public Property Get Acct() As String
    Acct = pAcct
End Property
Public Property Let Acct(Value As String)
    pAcct = Value
End Property

Public Property Get Base() As Currency
    Base = pBase
End Property
Public Property Let Base(Value As Currency)
    pBase = Value
End Property

Public Property Get VAT() As Currency
    VAT = pVAT
End Property
Public Property Let VAT(Value As Currency)
    pVAT = Value
End Property

Public Property Get Total() As Currency
    Total = pTotal
End Property
Public Property Let Total(Value As Currency)
    pTotal = Value
End Property

Public Property Get DocNum() As String
    DocNum = pDocNum
End Property
Public Property Let DocNum(Value As String)
    pDocNum = Value
End Property

常规模块

Option Explicit
'Set Reference to Microsoft Scripting Runtime
'   you can change this to late binding if everything works

Sub ReOrganizeTable()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dDoc As Dictionary, cD As cDoc
    Dim I As Long
    Dim V As Variant

'Set source and results worksheets
'Read source data into variant array

Set wsSrc = Worksheets("sheet1")
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With

On Error Resume Next
Set wsRes = Worksheets("Results")
    Select Case Err.Number
        Case 9
            Set wsRes = Worksheets.Add(after:=wsSrc)
            wsRes.Name = "Results"
        Case Is <> 0
            Debug.Print Err.Number, Err.Description
            Stop
    End Select
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)

'Gather and organize the data
Set dDoc = New Dictionary
For I = 2 To UBound(vSrc, 1)
    Set cD = New cDoc
    With cD
        .DocNum = vSrc(I, 1)
        .Acct = CStr(vSrc(I, 2))
        Select Case Left(.Acct, 1)
            Case 6, 7
                .Base = vSrc(I, 3)
            Case Else
                .VAT = vSrc(I, 3)
        End Select
        .Total = vSrc(I, 4)

        If Not dDoc.Exists(.DocNum) Then
            dDoc.Add Key:=.DocNum, Item:=cD
        Else
            dDoc(.DocNum).Base = dDoc(.DocNum).Base + .Base
            dDoc(.DocNum).VAT = dDoc(.DocNum).VAT + .VAT
            dDoc(.DocNum).Total = dDoc(.DocNum).Total + .Total
        End If
    End With
Next I

'Size results array
ReDim vRes(0 To dDoc.Count, 1 To 4)

'Headers
vRes(0, 1) = "Nr Doc"
vRes(0, 2) = "Base"
vRes(0, 3) = "VAT"
vRes(0, 4) = "Total"

'Populate the data area
I = 0
For Each V In dDoc.Keys
    I = I + 1
    Set cD = dDoc(V)
    With cD
        vRes(I, 1) = .DocNum
        vRes(I, 2) = .Base
        vRes(I, 3) = .VAT
        vRes(I, 4) = .Total
    End With
Next V

'write and format the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

结果

使用原始发布的数据

VBA ||转置唯一值和总和

2 个答案:

班级单元

常规模块

结果