Question

我正在尝试制作一个程序，该程序可以读取数据透视表并将每个字段的数据粘贴到数据库中，而所需的硬编码应尽可能少。

数据库的最上一行和左侧的一年中每个月的第一天都有类别。这里的目标是将我的支出数据在一个月内（汇总到数据透视表中），然后根据日期和类别将其动态粘贴到我的数据库中。

目前，该程序适用于大多数类别。莫名其妙地，它只想在我的一个测试数据透视表上工作。即使更改了引用，其他工作表或数据透视表也无法使用。由于某些原因，它也讨厌AJ列中的“其他”类别，即使我更改名称也不会发布到该类别。有时，它认为某事不好，只是中断。

如果数据透视表中的条目与类别不匹配，则会中断，这也是一个问题。

一旦程序中断，我必须退出VBA编辑器，然后重新打开它以使程序停止出错。

事情通常在ColNum = Sheet5.Cells(2, 1).EntireRow...行处中断，TypeName字段有时会具有一个类别名称，该类别名称甚至不在数据透视表中，而是我最后运行的测试。

Sub PivPasteNameData()
    'loop variables
    Dim I As Long
    Dim j As Long

    'pivot table variables
    Dim TypeName As String
    Dim TypeValue As Double

    'match variables
    Dim TodayDate As Range
    Dim DateRange As Range
    Dim CategoryRange As Range

    'paste variables
    Dim RowNum As Integer
    Dim ColNum As Integer

    'Setting match variables
    'this points to a cell on dashboard with today's date
    Set TodayDate = Sheet2.Range("C1")
    'this points to the left hand column of the database, it is the first of each month in ascending order
    Set DateRange = Sheet5.Range("A1:A100")
    'This points to all the categories across the top of the database
    Set CategoryRange = Sheet5.Range("A1:AZ2")

    'the index # will need to be variable
    Set PvTable = Sheet7.PivotTables(1)

    'first loop
    For I = 1 To PvTable.RowFields.Count
        'second loop
        For j = 1 To PvTable.RowFields(I).PivotItems.Count

            'setting the pivot tables field name (the type of the cost)
            TypeName = PvTable.RowFields(I).PivotItems(j)

            'getting the value of the cost
            TypeValue = Sheet7.PivotTables(1).GetPivotData("cost", "type", TypeName)

            'debugging
            'MsgBox TypeName
            'MsgBox TypeValue

            'find the corresponding date row numbner to the current date in the database
            RowNum = Application.WorksheetFunction.Match(TodayDate, DateRange, 1)
            'find the cost category column number in the database. For some reason I could NOT get Match working horizontally, my next attempt is going to use INDEX MATCH MATCH
            ColNum = Sheet5.Cells(2, 1).EntireRow.Find(What:=TypeName, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column

            'paste cost value in correct date/category
            Sheet5.Cells(RowNum, ColNum).Value = TypeValue
        Next j
    Next I
End Sub

VBA宏可动态粘贴“ n”个数据透视表字段值

0 个答案: