计分卡的 Excel VBA 循环

Question

这个让我有点难住。 正在寻找一个公式来帮助我为锦标赛做记分卡

基本上，如果 A 列中有有效名称（单词）并且 B 列中有数字，则将该数字复制到每行中的下一个空调用。

因此，A3 列可能有 Abe，B3 可能有 Abe 得分 20 分。将数字 20 作为值仅移动到第 3 行 E 列和 N 列之间的下一个空单元格。 我需要它循环遍历 A 列和 B 列中的所有姓名和分数，跳过空白

不确定它是否重要，但 A 列和 B 列是使用 XLookup 或其他索引填充的，如果可能，请忽略空值。

希望这足够清楚，抱歉这是我的第一篇文章，所以如果我需要添加更多信息，请告诉我。

尝试了一堆公式，但没有任何一个可以接近工作

Answer 1

用新值更新表

之前

之后

Sub UpdateWeeklyScores()

    ' Define constants.
    Const SCORE_FIRST_CELL_ADDRESS As String = "A3"
    Const SCORE_NAME_COLUMN As Long = 1
    Const SCORE_SCORE_COLUMN As Long = 2
    Const WEEK_FIRST_COLUMN As String = "E"
    Const WEEK_COLUMNS_COUNT As Long = 10
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the ranges.
    
    Dim srg As Range: Set srg = ws _
        .Range(SCORE_FIRST_CELL_ADDRESS).CurrentRegion
    
    Dim RowsCount As Long: RowsCount = srg.Rows.Count
    
    Dim wrg As Range: Set wrg = srg.EntireRow _
        .Columns(WEEK_FIRST_COLUMN).Resize(, WEEK_COLUMNS_COUNT)
    
    ' Return the values of the ranges in arrays.
    Dim sData() As Variant: sData = srg.Value
    Dim wData() As Variant: wData = wrg.Value
    
    ' Declare additional variables.
    Dim Value As Variant, r As Long, c As Long, IsScoreValid As Boolean
    
    ' Loop through the rows of the arrays and apply the logic
    ' to update the values (scores) in the week array.
    For r = 1 To RowsCount
        ' Determine if the score array's row values are valid.
        Value = sData(r, SCORE_NAME_COLUMN)
        IsScoreValid = False
        If Not IsError(Value) Then ' is no error
            If Len(CStr(Value)) > 0 Then ' is no blank
                Value = sData(r, SCORE_SCORE_COLUMN)
                If VarType(Value) = vbDouble Then ' is a number
                    IsScoreValid = True
                End If
            End If
        End If
        ' If the values are valid, write to the week array.
        If IsScoreValid Then
            ' Determine the column after the last non-blank column.
            For c = WEEK_COLUMNS_COUNT To 1 Step -1
                If Not IsEmpty(wData(r, c)) Then Exit For
            Next c
            ' Add new score.
            If c = WEEK_COLUMNS_COUNT Then ' last column is not empty
                For c = 1 To WEEK_COLUMNS_COUNT - 1
                    wData(r, c) = wData(r, c + 1)
                Next c
            Else ' last column is empty
                c = c + 1
            End If
            ' Write.
            wData(r, c) = Value
        End If
    Next r
    
    ' Replace the values in the week range with the values in the week array.
    wrg.Value = wData
    
    ' Inform.
    MsgBox "Weekly scores updated.", vbInformation

End Sub