Блог

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

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

Затем столбец последовательности будет выбирать наибольшее число в каждой последовательности.

Причина, по которой я хочу это сделать, заключается в том, что затем я могу запустить COUNTIFS в таблице, чтобы узнать, сколько раз игрок набирал очки подряд — например, 3pts в строке = 2, 2pts в строке = 3, 1pt в строке = 7.

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

Спасибо,

Саймон

 
 ------- ---------- --------- ---------- 
| Score |  Winner  | Counter | Sequence |
 ------- ---------- --------- ---------- 
| 0-0   | Player 1 |       1 |          |
| 15-0  | Player 1 |       2 |          |
| 30-0  | Player 1 |       3 |          |
| 40-0  | Player 1 |       4 |        4 |
| 0-0   | Player 1 |       1 |        1 |
| 15-0  | Player 2 |       1 |          |
| 15-15 | Player 2 |       2 |        2 |
| 15-30 | Player 1 |       1 |          |
| 30-30 | Player 1 |       2 |          |
| 40-30 | Player 1 |       3 |        3 |
| 0-0   | Player 2 |       1 |          |
| 0-15  | Player 2 |       2 |        2 |
| 0-30  | Player 1 |       1 |        1 |
| 15-30 | Player 2 |       1 |          |
| 15-40 | Player 2 |       2 |        2 |
| 0-0   | Player 2 |       1 |          |
 ------- ---------- --------- ---------- 


  

Сценарий, который я создал, может быть ужасно оптимизирован, но я попробовал.

Это должно работать при условии, что нужные вам данные находятся на первом листе (листы (1)) вашей книги. И предполагая, что структура данных соответствует приведенному вами примеру (colA = ОЦЕНКА, ColB = ПОБЕДИТЕЛЬ, ColC = СЧЕТЧИК, colD = Последовательность).

Для выполнения скрипта просто запустите вспомогательную процедуру main(). Он вызывает addcounter sub (который работает с ColC, COUNTER), а затем вызывает addseq (colD, SEQUENCE)

Для COUNTER я в значительной степени добавил счетчик, который будет сбрасываться всякий раз, когда оба результата будут равны 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" amp; 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 amp; 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" amp; 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 представляет первую ячейку диапазона данных из двух столбцов и ColumnOffset = 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 amp; 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
  

Если вам нужно выполнить много предварительной обработки, это может быть проще, Power Query чем VBA , но вот VBA процедура, которая сложнее, чем необходимо (см. Упрощенную версию Ниже), но она должна дать вам представление о том, как использовать классы, чтобы, возможно, дать вам несколько советов о том, какдля предварительной обработки ваших данных, как вы упомянули в комментарии.

• Я использовал объект Dictionary для сортировки и помощи в создании необходимых последовательностей.
• Я также использовал класс (объект) для хранения элементов для каждой последовательности.
• Я использовал массив vba для хранения и обработки данных, поскольку это НАМНОГО быстрее, чем несколько последовательностей чтения / записи на листе.

Обязательно либо установите ссылку Tools/References Microsoft Scripting Runtime , либо преобразуйте ссылки в позднюю привязку.

• Добавьте модуль класса и переименуйте его cScores

Модуль класса

 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

  

• Добавьте обычный модуль

 '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