Excel VBA需要添加一列来计算序列中出现的次数，并在出现给定值时重置

首先，我很抱歉，我知道这是为了发布初步尝试并寻求解决方案方面的帮助，但是我不知道从哪里开始

我希望在VBA中创建一个宏，将两个新列添加到数据表中，并使用从另一列中的数据创建的计数填充每个单元格。所以它本质上是计算一个序列。 例如，在下面的例子中，我添加了计数器列，它首先在优胜者列中的玩家出现时增加一个计数器。然后，当分数值=0-0时，它将重置，并再次启动

Sequence列随后将选择每个序列中的最大数字

我想这样做的原因是，我可以在桌子上运行COUNTIFS，查看一个玩家在一行中赢得点数的次数-例如一行中的3个=2，一行中的2个=3，一行中的1个=7

我希望这是有道理的。我正在努力找出最好的方法，但它需要在VBA中。我可以在原始数据表或实际的excel表版本上运行它，因为我可以访问这两个版本

谢谢

西蒙

---

我制作的脚本可能经过了极大的优化，但我尝试了一下

假设您想要的数据在工作簿的第一个工作表（工作表（1））中，它应该可以工作。假设数据结构遵循您给出的示例（colA=SCORE，colB=WINNER，colC=COUNTER，colD=Sequence）

要执行脚本，只需运行main（）子过程。 它调用addcounter sub（在colC、COUNTER上工作），然后调用addseq（colD、SEQUENCE）

对于计数器，我几乎添加了一个计数器，每当两个分数相加为0或玩家数量从1-2更改时，计数器将重置，反之亦然

对于序列，每当游戏结束（分数为40分）或玩家更换时，它都将计数

我在我的电脑上运行了这个脚本，在你给出的例子中得到了相同的结果

尝试一下，然后在评论中回复我，以解决可能出现的问题

请参见下面的代码

Option Explicit

Dim wb As Workbook
Dim tRow As Long

Dim sRng As Range
Dim cel As Range

Dim tArr() As String
Dim contar As Long
Dim i As Long

Dim a As String
Dim b As String

Sub main()

'sets wb as active workbook
Set wb = ThisWorkbook

'calls procedure that sets up COUNTER col
Call addcounter

'calls second procedure that fills the SEQUENCE col
Call addseq

End Sub



Private Sub addcounter()

'counts last row to obtain ubound of table range
tRow = crow(1, 1)

'sets range based on total row count and col a, excluding header, starts from A2
Set sRng = wb.Sheets(1).Range("A2:A" & tRow)

'bad practice, but i used on error to ignore any data type error when comparing variables
On Error Resume Next

'iterate through all the cells in sRng set up above
For Each cel In sRng

    'splits string under SCORE, and removes the dash, and stores the data in tArr array
    tArr = Split(cel.Value, "-")
    
    'a and b variables obtain the player numbers for the winner change check
    a = Replace(cel.Offset(0, 1).Value, "Player", "")
    b = Replace(cel.Offset(-1, 1).Value, "Player", "")
    
    'check for sum of the both scores, if zero, it resets the count
    i = CLng(tArr(0)) + CLng(tArr(1))

    'checks for counter reset, it checks for sum of both score 0 or if player 1 & 2 changed
    If i = 0 Or pcheck(a, b) = False Then
    
        contar = 1
    
        cel.Offset(0, 2).Value = contar

    Else
    
        contar = contar + 1
    
        cel.Offset(0, 2).Value = contar
    
    End If

Next cel

Set sRng = Nothing
Set cel = Nothing

End Sub



Private Sub addseq()

'counts last row to obtain ubound of table range
tRow = crow(1, 1)


Set sRng = wb.Sheets(1).Range("A2:A" & tRow)

On Error Resume Next
contar = 1

'iterate through all the cells in sRng set up above
For Each cel In sRng

    tArr = Split(cel.Value, "-")
    
    a = Replace(cel.Offset(0, 1).Value, "Player", "")
    b = Replace(cel.Offset(1, 1).Value, "Player", "")
    
    
    If cel.Offset(1, 0) = "" Then
        
        Set sRng = Nothing
        Set cel = Nothing

        Exit Sub
    
    ElseIf (tArr(0) = 40 Or tArr(1) = 40) Or pcheck(a, b) = False Then
    
        cel.Offset(0, 3).Value = contar
    
        contar = 1
    
    Else

        contar = contar + 1

    End If
    
Next cel

Set sRng = Nothing
Set cel = Nothing

End Sub

'The Functions used are below:

Private Function crow(s As Variant, c As Integer) As Long


    crow = Sheets(s).Cells(Rows.Count, c).End(xlUp).Row


End Function



Private Function pcheck(ByVal a As Long, ByVal b As Long) As Boolean


    If a = b Then
    
        pcheck = True
    
    Else
    
        pcheck = False
    
    End If

End Function

代码有点凌乱，但基于上面的示例，我得到了相同的结果。欢迎对最佳做法提出任何反馈意见

谢谢大家!

获取计数器序列

• 您只运行第一个过程，

  runCounterSequence

• 第二个过程，

  getCounterSequence

  ，在需要时由第一个过程调用
• 在本例中，

  A2

  表示两列数据范围的第一个单元格，

  columnsoffset=2

  表示将从单元格

  C2

  开始写入相同大小的结果

代码

Option Explicit

Sub runCounterSequence()
    
    ' Constants
    Const wsName As String = "Sheet1"
    Const FirstDataCell As String = "A2"
    Const ColumnOffset As Long = 2
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Define worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(wsName)
    On Error GoTo 0
    
    ' Validate worksheet.
    If ws Is Nothing Then
        GoTo ProcExit
    End If
    
    ' Transform values from Source Range to Data Array ('Data').
    Dim Data As Variant
    Data = getCounterSequence(ws, FirstDataCell)
    
    ' Validate Data Array.
    If IsEmpty(Data) Then
        GoTo ProcExit
    End If
    
    ' Define Target First Data Row Range ('rng').
    Dim rng As Range
    Set rng = ws.Range(FirstDataCell).Offset(, ColumnOffset).Resize(, 2)
    
    ' Write values from Data Array to Target Range.
    With cel
        ' Clear contents from Target First Data Row Range to the bottom.
        .Resize(ws.Rows.Count - rng.Row + 1).ClearContents
        ' Write values from Data Array to Target Range.
        .Resize(UBound(Data, 1)).Value = Data
    End With
    
    ' Inform user.
    MsgBox "Counter & Sequence written.", vbInformation, "Success"

ProcExit:

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      ?
' Remarks:      The result is a 2D two-column one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getCounterSequence(Sheet As Worksheet, _
                            Optional ByVal FirstDataCell As String = "A1") _
         As Variant
    
    ' Define Data Range ('rng')
    
    ' Validate worksheet.
    If Sheet Is Nothing Then
        GoTo ProcExit
    End If
    ' Validate First Data Cell (and define its row).
    On Error GoTo ProcExit
    Dim FirstRow As Long
    FirstRow = Sheet.Range(FirstDataCell).Row
    On Error GoTo 0
    ' Continue...
    Dim FirstCol As Long
    FirstCol = Sheet.Range(FirstDataCell).Column
    Dim LastRow As Long
    LastRow = Sheet.Cells(Sheet.Rows.Count, FirstCol).End(xlUp).Row
    ' Validate Last Non-Empty Row.
    If FirstRow > LastRow Then
        GoTo ProcExit
    End If
    ' Continue...
    Dim rng As Range
    Set rng = Sheet.Range(FirstDataCell).Resize(LastRow - FirstRow + 1, 2)
    Dim DataCount As Long
    DataCount = rng.Rows.Count
    
    ' Write values from Data Range to Data Array ('Data').
    
    Dim Data As Variant
    Data = rng.Value
    
    ' Modify values in Data Array.
    
    ' Modify first row.
    Dim Previous As String
    Data(1, 1) = 1
    Previous = Data(1, 2)
    Data(1, 2) = Empty
    If DataCount = 1 Then
        GoTo writeResult
    End If
    ' Modify remaining rows.
    Dim i As Long
    For i = 2 To DataCount
        If Data(i, 1) = "0-0" Then
            Data(i, 1) = 1
            Previous = Data(i, 2)
            Data(i - 1, 2) = Data(i - 1, 1)
        Else ' Data(i, 1) <> "0-0"
            If Data(i, 2) = Previous Then
                Data(i, 1) = Data(i - 1, 1) + 1
            Else ' Data(i, 2) <> Previous
                Data(i, 1) = 1
                Previous = Data(i, 2)
                Data(i - 1, 2) = Data(i - 1, 1)
            End If
        End If
        Data(i, 2) = Empty
    Next i
 
    ' Write result.

writeResult:
    getCounterSequence = Data
    
ProcExit:

End Function

Option Explicit
Private pScore As String
Private pScores As Dictionary
Private pWinner As String

Public Property Get Score() As String
    Score = pScore
End Property
Public Property Let Score(Value As String)
    pScore = Value
End Property

Public Property Get Scores() As Dictionary
    Set Scores = pScores
End Property
Public Function addScoresItem(Value)
    If pScores.Exists(Value) Then
        MsgBox "Duplicate key will not be added"
    Else
        pScores.Add Value, Value
    End If
End Function

Public Property Get Winner() As String
    Winner = pWinner
End Property
Public Property Let Winner(Value As String)
    pWinner = Value
End Property

Private Sub Class_Initialize()
    Set pScores = New Dictionary
End Sub

Option Explicit
Sub PlayerScoring()
    Dim wsSrc As Worksheet, rRes As Range
    Dim vData As Variant, vRes As Variant
    Dim lKey As Long
    Dim dS As Dictionary
    Dim I As Long, J As Long, v
    
'Set source and results worksheet and ranges
'read source data into VBA array for faster processing
Set wsSrc = Worksheets("Sheet1")
With wsSrc
    'this is one of many ways to find the relevant range.
    vData = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
    ReDim vRes(1 To UBound(vData, 1), 1 To UBound(vData, 2))
        vRes(1, 1) = "Counter"
        vRes(1, 2) = "Sequence"
    Set rRes = Range(.Cells(1, 3), .Cells(UBound(vData, 1), 4))
End With


'split up the relevant data for each sequence
'and store in dictionary so as to easily count
Set dS = New Dictionary
lKey = 0
For I = 2 To UBound(vData)
    If vData(I, 1) = "0-0" Or vData(I, 2) <> vData(I - 1, 2) Then lKey = lKey + 1
    If Not dS.Exists(lKey) Then
            dS.Add Key:=lKey, Item:=1
    Else
        dS(lKey) = dS(lKey) + 1
    End If
Next I

'Populate results
I = 2
For Each v In dS
    With dS(v)
        'populate counter
        For J = 0 To dS(v)
        
            'check for last entry
            If I + J > UBound(vData) Then
                J = J + 1
                Exit For
            End If
            
            vRes(I + J, 1) = J + 1
        Next J
        'populate sequence
        vRes(I + J - 2, 2) = dS(v)
        I = I + J - 1
    End With
Next v
    

With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub

选项显式
子运行计数器序列（）
“常数
Const wsName As String=“Sheet1”
常量FirstDataCell为String=“A2”
Const ColumnOffset（长度=2）
将wb设置为工作簿
将wb=ThisWorkbook设置为包含此代码的工作簿。
'定义工作表
将ws设置为工作表
出错时继续下一步
设置ws=wb.Worksheets（wsName）
错误转到0
'验证工作表。
如果ws什么都不是，那么
转到出口
如果结束
'将值从源范围转换为数据数组（'数据'）。
作为变量的Dim数据
数据=getCounterSequence（ws，FirstDataCell）
'验证数据数组。
如果是空的（数据），那么
转到出口
如果结束
'定义目标第一数据行范围（'rng'）。
变暗rng As范围
设置rng=ws.Range（FirstDataCell）.Offset（，ColumnPostate）.Resize（，2）
'将值从数据数组写入目标范围。
和cel
'清除从目标第一个数据行范围到底部的内容。
.Resize（ws.Rows.Count-rng.Row+1）.ClearContent
'将值从数据数组写入目标范围。
.Resize（UBound（数据，1））。值=数据
以
'通知用户。
MsgBox“已写入计数器和序列”，vbInformation，“成功”
程序出口：
端接头
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
“目的：？”？
'备注：结果是一个二维双列一基数组。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
函数getCounterSequence（作为工作表的工作表_
可选的ByVal FirstDataCell格式为String=“A1”）_
作为变体
'定义数据范围（'rng'）
'验证工作表。
如果床单什么都不是
转到出口
如果结束
'验证第一个数据单元（并定义其行）。
错误转到PROCEXT
第一排一样长
FirstRow=Sheet.Range（FirstDataCell）.Row
错误转到0
“继续。。。
长得一样暗
FirstCol=Sheet.Range（FirstDataCell）.Column
最后一排一样长
LastRow=Sheet.Cells（Sheet.Rows.Count，FirstCol）.End（xlUp）.Row
'验证最后一个非空行。
如果第一行>最后一行，则
转到出口
如果结束
“继续。。。
变暗rng As范围
设置rng=Sheet.Range（FirstDataCell）。调整大小（LastRow-FirstRow+1,2）
将数据计数变长
数据计数=rng.Rows.Count
'将值从数据范围写入数据数组（'数据'）。
作为变量的Dim数据
数据=平均值
'修改数据数组中的值。
'修改第一行。
将上一个设置为字符串
数据（1，1）=1
先前=数据（1，2）
数据（1，2）=空
如果DataCount=1，则
转到writeResult
如果结束
'修改其余行。
我想我会坚持多久
对于i=2到DataCount
如果数据（i，1）=“0-0”，则
数据（i，1）=1
先前=数据（i，2）
数据（i-1,2）=数据（i-1,1）
Else的数据（i，1）“0-0”
如果数据（i，2）=之前，则
数据（i，1）=数据（i-1，1）+1
Else的数据（i，2）以前
数据（i，1）=1
先前=数据（i，2）
Dat
'Set reference to Microsoft Scripting Runtime
Option Explicit
Sub PlayerScoring()
    Dim wsSrc As Worksheet
    Dim vData As Variant
    Dim lKey As Long
    Dim dS As Dictionary, cS As cScores
    Dim I As Long, J As Long, v
    
'Set source and results worksheet and ranges
'read source data into VBA array for faster processing
Set wsSrc = Worksheets("Sheet1")
With wsSrc
    'this is one of many ways to find the relevant range.
    vData = .Cells(1, 1).CurrentRegion.Resize(columnsize:=4)
    vData(1, 3) = "Counter"
    vData(1, 4) = "Sequence"
End With


'split up the relevant data for each sequence
'and store in dictionary so as to easily count
Set dS = New Dictionary
lKey = 0
For I = 2 To UBound(vData)
    Set cS = New cScores
    If vData(I, 1) = "0-0" Or vData(I, 2) <> vData(I - 1, 2) Then lKey = lKey + 1
    If Not dS.Exists(lKey) Then
        With cS
            .Score = vData(I, 1)
            .Winner = vData(I, 2)
            .addScoresItem .Score
            dS.Add Key:=lKey, Item:=cS
        End With
    Else
        dS(lKey).addScoresItem vData(I, 1)
    End If
Next I

'Populate results
I = 2
For Each v In dS
    With dS(v)
        'populate counter
        For J = 0 To .Scores.Count
        
            'check for last entry
            If I + J > UBound(vData) Then
                J = J + 1
                Exit For
            End If
            
            vData(I + J, 3) = J + 1
        Next J
        'populate sequence
        vData(I + J - 2, 4) = .Scores.Count
        I = I + J - 1
    End With
Next v
    
Dim rRes As Range
Set rRes = wsSrc.Cells(1, 12).Resize(rowsize:=UBound(vData, 1), columnsize:=UBound(vData, 2))
With rRes
    .EntireColumn.Clear
    .Value = vData
    .Style = "output"
    .EntireColumn.AutoFit
End With

End Sub


Option Explicit
Sub PlayerScoring()
    Dim wsSrc As Worksheet, rRes As Range
    Dim vData As Variant, vRes As Variant
    Dim lKey As Long
    Dim dS As Dictionary
    Dim I As Long, J As Long, v
    
'Set source and results worksheet and ranges
'read source data into VBA array for faster processing
Set wsSrc = Worksheets("Sheet1")
With wsSrc
    'this is one of many ways to find the relevant range.
    vData = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
    ReDim vRes(1 To UBound(vData, 1), 1 To UBound(vData, 2))
        vRes(1, 1) = "Counter"
        vRes(1, 2) = "Sequence"
    Set rRes = Range(.Cells(1, 3), .Cells(UBound(vData, 1), 4))
End With


'split up the relevant data for each sequence
'and store in dictionary so as to easily count
Set dS = New Dictionary
lKey = 0
For I = 2 To UBound(vData)
    If vData(I, 1) = "0-0" Or vData(I, 2) <> vData(I - 1, 2) Then lKey = lKey + 1
    If Not dS.Exists(lKey) Then
            dS.Add Key:=lKey, Item:=1
    Else
        dS(lKey) = dS(lKey) + 1
    End If
Next I

'Populate results
I = 2
For Each v In dS
    With dS(v)
        'populate counter
        For J = 0 To dS(v)
        
            'check for last entry
            If I + J > UBound(vData) Then
                J = J + 1
                Exit For
            End If
            
            vRes(I + J, 1) = J + 1
        Next J
        'populate sequence
        vRes(I + J - 2, 2) = dS(v)
        I = I + J - 1
    End With
Next v
    

With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub