时间戳

首页 > 解决方案 > 在此项目中进行一些更改后，无法让 VBA 数组写回工作表

excel - 在此项目中进行一些更改后，无法让 VBA 数组写回工作表

问题描述

我有 10 列来自每周发布的工作表（“玩家跟踪”）。我正在使用该跟踪表来更新主文件工作表（“播放器目录”）。这段代码正在做它应该做的事情，但是在为项目添加了一些改进之后，这部分不起作用。我做了什么？

1 玩家跟踪表应该发生什么 - 玩家 ID、姓名、屏幕名称、代理名称、代理 ID、费用、RB%、Adj RB、总手数和现金手数。SrcColumns 数组（2、3、4、5、6、7、8、10、11、14）。

2 Player Directory 应该与 PLayer Tracking 进行比较，以查看是否有任何更新或添加。类别相同，但行略有不同。Trgtcolumns 数组(2, 3, 4, 10, 11, 13, 12, 14, 15, 16, 17)

3 如果要添加行，则应该添加行以确保容量。最后 6 列是应该累积的数字。例如。费用是玩家跟踪的第 7 列。如果该单元格的值为 10，而每周报告的值为 2。我希望将现有的 10 与 2 相加，因此它现在将显示为 12。

此外，我没有收到任何错误代码，但我的代码也可能阻止了这种情况。当我运行代码时，看起来事情正在发生。即使当我逐步浏览它时，一切看起来都很好，但是当 sub 结束时，目录页面仍然是空白的。

    `Sub DirectoryAdds()
    Const tgtName As String = "Player Directory"
    Const srcFirstRow As Long = 4
    Const tgtFirstRow As Long = 4
    Dim srcColumns As Variant: srcColumns = Array(2, 3, 4, 5, 6, 7, 8, 10, 11, 13, 14)
    Dim tgtColumns As Variant: tgtColumns = Array(2, 3, 4, 10, 11, 13, 12, 14, 15, 16, 17)
    Dim PT As Worksheet: Set PT = PokerBros.Worksheets(Worksheets.Count)
    Dim PD As Worksheet: Set PD = ThisWorkbook.Worksheets(tgtName)
    Dim rng As Range
    Dim Source As Variant, Target As Variant
    Dim NewRow As Long
    Dim Curr As Long
    Dim UB As Long
    Dim i As Long
    Dim k As Long
        If PT Is PD Then MsgBox "Wrong sheet selected.": GoTo exitProcedure
    Set rng = PT.Columns(srcColumns(0)).Find("*", , xlFormulas, , , xlPrevious)
        If rng Is Nothing Then GoTo exitProcedure
        If rng.row < srcFirstRow Then GoTo exitProcedure
        Source = PT.Range(PT.Cells(srcFirstRow, srcColumns(0)), rng)
    Set rng = PD.Columns(tgtColumns(0)).Find("*", , xlFormulas, , , xlPrevious)
        If rng Is Nothing Then GoTo exitProcedure
        If rng.row < tgtFirstRow Then GoTo exitProcedure
        Target = PD.Range(PD.Cells(tgtFirstRow, tgtColumns(0)), rng)
        NewRow = rng.row + 1
        UB = UBound(srcColumns)
        For i = 1 To UBound(Source)
            On Error Resume Next
            Curr = WorksheetFunction.Match(Source(i, 1), Target, 0)
            If Err.Number = 0 Then
                On Error GoTo 0
                GoSub updateExistingRecord
            Else
                On Error GoTo 0
                GoSub addNewRecord
            End If
        Next
        MsgBox "Operation finished successfully."    
        GoTo exitProcedure        
updateExistingRecord:
    Set rng = PD.Cells(Curr + tgtFirstRow - 1, tgtColumns(UB))
        rng.Value = rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value
    Return
addNewRecord:
        For k = 0 To UB - 1
            PD.Cells(NewRow, tgtColumns(k)).Value = _
              PT.Cells(i + srcFirstRow - 1, srcColumns(k)).Value
        Next k
    Set rng = PD.Cells(NewRow, tgtColumns(UB))
        rng.EntireRow.Insert
        rng.Value = rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value
        NewRow = NewRow + 1
    Return
exitProcedure:
Erase srcColumns
Erase tgtColumns    
updateExistingRecord: Set rng = PD.Cells(Curr + tgtFirstRow - 1, tgtColumns(UB)) rng.Value = 
rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value Return addNewRecord: For k = 0 To 
UB - 1 PD.Cells(NewRow, tgtColumns(k)).Value = _ PT.Cells(i + srcFirstRow - 1,  srcColumns(k)).Value 

Next k Set rng = PD.Cells(NewRow, tgtColumns(UB)) rng.EntireRow.Insert  

.Value = rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value NewRow = NewRow + 1 Return exitProcedure: Erase srcColumns Erase tgtColumns End Sub`

`

标签： excelvbamatchingdynamic-arrays

解决方案

没有 goto/gosub

编译但未测试。

编辑：简化/更新以删除变体数组

Sub DirectoryAdds()

    Const tgtName As String = "Player Directory"
    Const srcFirstRow As Long = 4
    Const tgtFirstRow As Long = 4
    Dim srcColumns As Variant, tgtColumns As Variant
    Dim PT As Worksheet, PD As Worksheet
    Dim rng As Range, rngSource As Range, c As Range
    Dim NewRow As Long, Curr, UB As Long, i As Long, k As Long

    srcColumns = Array(2, 3, 4, 5, 6, 7, 8, 10, 11, 13, 14)
    tgtColumns = Array(2, 3, 4, 10, 11, 13, 12, 14, 15, 16, 17)
    UB = UBound(srcColumns)

    Set PT = PokerBros.Worksheets(Worksheets.Count) 'what is PokerBros?
    Set PD = ThisWorkbook.Worksheets(tgtName)

    If PT Is PD Then
        MsgBox "Wrong sheet selected."
        Exit Sub
    End If

    Set rngSource = PT.Range(PT.Cells(srcFirstRow, srcColumns(0)), _
                             PT.Cells(Rows.Count, srcColumns(0)).End(xlUp))

    For Each c In rngSource.Cells
        If Len(c.Value) > 0 Then
            'Simpler to search full column, but assumes there will be no match
            '  in the header or the cells above it...
            Curr = Application.Match(c.Value, PD.Columns(tgtColumns(0)), 0) 'no Worksheetfunction=no runtime error if no match
            If Not IsError(Curr) Then
                'increment last column
                With PD.Cells(Curr, tgtColumns(UB))
                    .Value = .Value + PT.Cells(c.Row, srcColumns(UB)).Value
                End With
            Else
                'no match: copy over
                Set rng = PD.Cells(Rows.Count, tgtColumns(0)).End(xlUp).Offset(1, 0)
                For k = 0 To UB - 1
                    PD.Cells(rng.Row, tgtColumns(k)).Value = PT.Cells(c.Row, srcColumns(k)).Value
                Next k

                'not sure what the insert is for?
                'rng.EntireRow.Insert
                'rng.Value = rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value
            End If 'got a match
        End If     'have a value to search for
    Next c
    MsgBox "Operation finished successfully."

End Sub

推荐阅读