Блог

Я новичок в макросах, поэтому, пожалуйста, извините меня, если это ЭЛЕМЕНТАРНО. Я попытался поискать, но не смог найти ответа.

• Вот постановка проблемы :

В столбце A на приведенном ниже листе есть «Имена поставщиков», а в столбце B — «Рекомендация на уровне строки», значения которой могут варьироваться от 1 до 5.

Все, что мне нужно, это чтобы макрос прошел по столбцу Имена поставщиков и прочитал соответствующие значения сценария в столбце B, если значение найдено, то под соответствующим столбцом сценария должна быть отметка «X».

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

Формат, который мне нужен, выглядит следующим образом

Результат, который я получаю с помощью своего макроса, таков

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

 Sub scenario_finder()
 r = 2
 Do While Cells(r, 1) <> ""
 If Cells(r, 2) = "Scenario 1" Then
 Cells(r, 3) = "X"
 ElseIf Cells(r, 2) = "Scenario 2" Then Cells(r, 4) = "X"
 ElseIf Cells(r, 2) = "Scenario 3" Then Cells(r, 5) = "X"
 ElseIf Cells(r, 2) = "Scenario 4" Then Cells(r, 6) = "X"
 ElseIf Cells(r, 2) = "Scenario 5" Then Cells(r, 7) = "X"
 Else
 Cells(r, 8) = ""
 
 End If
 r = r   1
 Loop
End Sub
 

Любая помощь с псевдокодом будет очень признательна, так как я раньше не работал с VBA и не очень хорошо знаю синтаксис.

Спасибо!

Добавлено 8/4/2021 Заказчику для анализа необходимо следующее — Таблица 3

Используйте переменную для отслеживания строки, в которую вы хотите записать.

Назначьте эту переменную первой в цикле

Что-то вроде

 Sub scenario_finder()
    Dim ws as Worksheet
    Dim r as long
    Dim VendorHeaderRow as long 

    Set ws = ActiveSheet ' or whatever sheet you want
    With ws
        r = 2
        VendorHeaderRow = r
        Do While .Cells(r, 1) <> vbNullString 
            If .Cells(r - 1, 1).Value2 <> .Cells(r, 1).Value2 Then
                VendorHeaderRow = r
            End If

            Select Case .Cells(r, 2).Value2
               Case "Scenario 1"
                   .Cells(VendorHeaderRow, 3).Value2 = "X"
               Case "Scenario 2"
                   .Cells(VendorHeaderRow, 4).Value2 = "X"
               Case "Scenario 3"
                   .Cells(VendorHeaderRow, 5).Value2 = "X"
               Case "Scenario 4"
                   .Cells(VendorHeaderRow, 6).Value2 = "X"
               Case "Scenario 5"
                   .Cells(VendorHeaderRow, 7).Value2 = "X"
            End Select
            r = r   1
        Loop
    End With
End Sub
 

Уникальный

• Предполагается, что существует только две колонки (поставщики, сценарии). Он запишет полученные заголовки и данные рядом с ними.

 Option Explicit

Sub ScenarioFinder()
    
    ' The Range.
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim rCount As Long: rCount = rg.Rows.Count
    If rCount = 1 Then Exit Sub
    
    ' Vendor Column
    Dim vcrg As Range: Set vcrg = rg.Columns(1).Resize(rCount - 1).Offset(1)
    Dim vData As Variant: vData = vcrg.Value
    
    ' Scenario Column
    Dim scrg As Range: Set scrg = vcrg.Offset(, 1)
    Dim sArr As Variant: sArr = ArrUniqueColumnRange(scrg)
    Dim sUpper As Long: sUpper = UBound(sArr)
    Dim sData As Variant: sData = scrg.Value
    
    ' Define the Destination Array.
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To sUpper   1)
    
    Dim rIndex As Long
    Dim cIndex As Long
    Dim r As Long
    Dim c As Long
    
    ' Write headers.
    For c = 0 To sUpper
        dData(1, c   1) = sArr(c)
    Next c
    
    ' Write the data.
    For r = 1 To UBound(vData, 1)
        rIndex = Application.Match(vData(r, 1), vcrg, 0)   1
        cIndex = Application.Match(sData(r, 1), sArr, 0)
        dData(rIndex, cIndex) = "X"
    Next r
    
    ' Create a reference to the Destination Range.
    Dim drg As Range: Set drg = rg.Resize(, UBound(sArr)   1).Offset(, 2)
    
    ' Write values from the Destination Array to the Destination Range.
    drg.Value = dData
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a one-column range in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueColumnRange( _
    ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    
    Dim Data As Variant
    Dim rCount As Long
    
    With ColumnRange.Columns(1)
        rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim r As Long
        For r = 1 To rCount
            Key = Data(r, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = Empty
                End If
            End If
        Next r
        If .Count = 0 Then Exit Function ' only error values and/or blanks
        ArrUniqueColumnRange = .Keys
    End With

End Function