Не удается получить массив VBA для обратной записи на лист после внесения некоторых изменений в этот проект

Question

У меня есть 10 столбцов из рабочего листа («Отслеживание игроков»), который выходит еженедельно. Я использую этот лист отслеживания для обновления рабочего листа основного файла («Каталог игрока»). Этот код делал именно то, что должен был делать, но после добавления некоторых улучшений в проект эта часть не работает. Что я сделал?

1 Что должно произойти с листом отслеживания игроков - идентификатор игрока, имя, экранное имя, имя агента, идентификатор агента, гонорар, процент RB, корректировка RB, общее количество рук и Ca sh Руки. SrcColumns Массив (2, 3, 4, 5, 6, 7, 8, 10, 11, 14).

2 Предполагается, что каталог игрока сравнивается с отслеживанием игрока, чтобы увидеть, есть ли какие-либо обновления или дополнения. Категории те же, но строки немного отличаются. Trgtcolumns Array (2, 3, 4, 10, 11, 13, 12, 14, 15, 16, 17)

3 Если есть добавления, которые должны быть сделаны, предполагается, что строки должны быть добавлены для обеспечения емкости. Последние 6 столбцов - это числа, которые должны просто накапливаться. так например. Плата находится в 7-м столбце отслеживания игроков. Если бы эта ячейка имела значение 10, а еженедельный отчет имел значение 2. Я бы хотел, чтобы существующие 10 были добавлены к 2, чтобы теперь было указано 12.

Также я не получаю никаких кодов ошибок но мой код тоже может предотвращать это. когда я запускаю код, похоже, что что-то происходит. даже когда я прохожу через него, все выглядит нормально, но когда подпрограмма заканчивается, страница каталога все еще пуста.

    `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`

`

Answer 1

Без 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