VBA: Mark ,,x,, if conditions are met-CodePudding

Im not really experienced at VBA and also this is my first time writing here, but still i gave it a try. I think i start with what ive tried to do, at the start, i set some conditions for ,,x,, marking. I wrote a code that wrote ,,x,, to column AN when it found any value from column F.

After that i wanted the ,,x,, to appear only one time per match. (So no duplicates from column F).

That worked, but thats not the goal, thats only where i could get.

After the code im explaining what i have to achieve

Code so far:

Sub mark_x()

Dim lastRow As Long
Dim values As New Collection

lastRow = ActiveSheet.Cells(Rows.Count, "F").End(xlUp).Row

For i = 2 To lastRow
    If Not IsEmpty(Cells(i, "F")) Then
        On Error Resume Next
        values.Add Cells(i, "F").Value, CStr(Cells(i, "F").Value)
        If Err.Number <> 0 Then
            Cells(i, "AN").Value = "x"
        End If
        On Error GoTo 0
    End If
Next i

End Sub

So here iam describing what i want to achieve:

I have an excel file, where my main focus are columns C,E,F and AN.

C - Item number, E - Country, F - Supplier and AN - X mark

I need to have an X mark in column AN when: -condition is that X in AN can be only once for item - C , supplier - F and country - E So for example

There will be always the same countries: SK,CZ,RO,PL,HR,BG,DE

-also there are multiple rows, ive only made a screen of few

-i was trying to get it right but i cant :(

Im sorry, if i wrote the post in the wrong way.

CodePudding user response：

Hi welcome to Stack Overflow,

I believe you asked the question correctly. At least you made clear what was the desired output.

So what you want to do is: to set a value of "x" to those rows where the union of some given values are distinct. Here is my solution code (you can find some comments so you can understand everything):

Sub markDistinct()
    ' Declaration of some variables
    Dim rowsNum As Integer
    Dim rgToFilter As Range
    
    ' This code will consider your headers are in the 1st row and your data at 2nd row
    ' Change cell references otherwise
    
    ' Concat formula of the columns of interest (C, E, F)
    ' Place the formula in the first data row of column AN (the one we will fill with "x")
    Range("AN2").Formula = "=CONCATENATE(C2,E2,F2)"
    
    ' Store the number of rows of your data
    rowsNum = Range("C1").End(xlDown).Row
    
    ' Select the range we will filter (column AN)
    Set rgToFilter = Range("AN2:AN" & rowsNum)
    ' Drop down the concat formula to all the rows
    rgToFilter.FillDown
    
    ' Filter by distinct concatenation values
    Range("AN1:AN" & rowsNum).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    
    ' For each distinct filtered values assign the value "x" in the AN column
    For Each cl In rgToFilter.SpecialCells(xlCellTypeVisible)
        cl.Value = "x"
    Next cl
    
    ' Unfilter data
    ActiveSheet.ShowAllData
    
    ' For each cell in column AN, if its value is different from "x", then empty/clear it 
    For r = 2 To rowsNum
        If Cells(r, "AN") <> "x" Then Cells(r, "AN").ClearContents
    Next r
End Sub

Although I have tried to adapt it as much as possible to your needs, you may have to make small changes to make it fit your data. Hope it helps

CodePudding user response：

Flag First (Multi-Column) Rows

Flags the first rows i.e. the rows that would remain after running the following:

ws.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(3, 5, 6), Header:=xlYes

Option Explicit

Sub FlagFirstRows()

    Const DST_COL As Long = 40 ' AN
    Const DST_FLAG As String = "x"
    Const SRC_DELIMITER As String = "@"
    Dim sCols(): sCols = VBA.Array(3, 5, 6) ' C, E, F
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim rg As Range, rCount As Long

    With ws.Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        If rCount = 0 Then Exit Sub
        Set rg = .Resize(rCount).Offset(1)
    End With
    
    Dim sData(): sData = rg.Value
    Dim dData(): ReDim dData(1 To rCount, 1 To 1)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim cUB As Long: cUB = UBound(sCols)
    
    Dim r As Long, c As Long, rString As String
    
    For r = 1 To rCount
        rString = sData(r, sCols(0))
        For c = 1 To cUB
            rString = rString & SRC_DELIMITER & sData(r, sCols(c))
        Next c
        If Not dict.Exists(rString) Then
            dict(rString) = Empty
            dData(r, 1) = DST_FLAG
        End If
    Next r
    
    rg.Columns(DST_COL).Value = dData

    MsgBox "First rows flagged.", vbInformation
    
End Sub