If two cells are equal mark as unique

[Snnnider]

Hello

As a bit of context. I have a large file with about 150 different suppliers. I want to make a macro which loops through each of these suppliers, and copies each row which contains a supplier into a different file. So for example if there are 6 rows of supplier 6, then all these rows are copied to a new file.

I am working on the first part of identifying the unique suppliers, for the moment just marking them with a unique value (numbered 1 - 150). This is my code so far:

Sub invoiceSupplierSplit()
Worksheets("Invoice Report").Activate
Cells(2, 73) = "Unique Supplier"

Dim i As Integer
i = 3

Do While Cells(i, 2).Value <> ""
Cells(i, 73) = "value"
i = i + 1
Loop

End Sub

So it loops through Column B, as long as the cell is not empty then put value into its counterpart on column BU. SO if B2 has something, then BU2 = value

How could I check that if B2 and B3 are equal write i to BU2, then if B3 and B4 are equal i to BU3. However if B4 and B5 are different then write i+1 to BU4 and so on until the end of the file.

This code is more a proof of concept before I continue and copy these values instead of just writing to the end column

I hope this makes sense and any help would be very much appreciated
Josh

 

[JackDanIce]

Welcome to the board. Try:

Sub Macro1()

Dim ws      As Excel.Worksheet
Dim x       As Long

    Application.ScreenUpdating = False
    
    Set ws = Worksheets("Invoice Report")
    
    With ws

        .Cells(2, 73).Value = "Unique Supplier"

        For x = 3 To .Range("B" & .Rows.Count).End(xlUp).Row

            .Cells(x, 73).Value = x

            If .Cells(x, 2).Value <> .Cells(x + 1, 2).Value Then
                .Cells(x, 73).Value = x + 1
            End If

        Next x

    End With
    
    Set ws = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

 

[Snnnider]

Hey thank you very much. It certainly works a lot faster than mine, mine would just crash

However it isnt assigning a unique number to each supplier, I find if I change the <> on the if statement to an equal then it works for the first supplier, but after that it just assigns a unique value to every row rather than every supplier

I greatly appreciate you helping me this much however! Thank you for the welcome to

 If .Cells(x, 2).Value <> .Cells(x + 1, 2).Value Then
                .Cells(x, 73).Value = x + 1

 

[JackDanIce]

No probs. You original code suggests the word "value" in each row of column 73 as it loops through column B (2):

i = 3

Do While Cells(i, 2).Value <> ""
Cells(i, 73) = "value"
i = i + 1
Loop

Your post then says:

How could I check that if B2 and B3 are equal write i to BU2, then if B3 and B4 are equal i to BU3. However if B4 and B5 are different then write i+1 to BU4 and so on until the end of the file.

Try this, if this is what you mean:

Sub Macro2()

Dim ws      As Excel.Worksheet
Dim x       As Long
Dim Unique  As Long

    Application.ScreenUpdating = False
    
    Set ws = Worksheets("Invoice Report")
    Unique = 1
    
    With ws
        .Cells(2, 73).Value = "Unique Supplier"

        For x = 3 To .Range("B" & .Rows.Count).End(xlUp).Row
            If .Cells(x, 2).Value <> .Cells(x + 1, 2).Value Then
                Unique = Unique + 1
            End If
            .Cells(x, 73).Value = Unique
        Next x
    End With
    
    Set ws = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

 

[Snnnider]

My apologies, I was thinking while typing

That is however perfect, exactly what I wanted! Thank you very much!!

Now onto the rest of the project, wish me luck

 

[Snnnider]

One thing I did notice was the values were offset slightly, so I tweaked the code to amend this, other than that perfect! again thank you much appreciated

Sub MacroTestTwo()
Dim ws      As Excel.Worksheet
Dim x       As Long
Dim Unique  As Long


    Application.ScreenUpdating = False
    
    Set ws = Worksheets("Invoice Report")
    Unique = 1
    
    With ws
        .Cells(2, 73).Value = "Unique Supplier"


        For x = 3 To .Range("B" & .Rows.count).End(xlUp).Row
            If .Cells(x, 2).Value <> .Cells(x + 1, 2).Value Then
                Unique = Unique + 1
            End If
            .Cells(x + 1, 73).Value = Unique
        Next x
    End With
    
    Set ws = Nothing
    
    Cells(3, 73) = 1
    
    Application.ScreenUpdating = True
    
End Sub

 

[JackDanIce]

Glad it works, good luck with rest of project.