VBA to Assign category numbers

[BORUCH]

hi all
i have an excel sheet that looks like below

I'm looking for a VBA that would automate for me column D and assign category numbers starting with 001 002 etc..

the criteria is if they are are all the same price, but also right underneath each other so for example the item number 00001 and item number c123 are both 100 dollars but not the same group

there will always be an empty row between each group

any help is greatly appreciated

thanks

 

[BORUCH]

Are you saying that the category results and the prices may not be in adjacent columns?

Would the rows always correspond? That is, if the 'Price' heading is in row 7 somewhere would the 'Category' heading also be in row 7 somewhere?

Need to understand just what sort of variation(s) you are contemplating. Please try to explain clearly, preferably with examples.

yes so the formula works perfect if everything is in the right column but sometimes it can change i will attach a sample

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	ITEM #	DESCRIPTION	PRICE	CATEGORY RESULTS		ITEM #	DESCRIPTION			PRICE					CATEGORY RESULTS
2	0001	Chains	$ 14.60			0001	Chains			$ 14.60
3	0001	Socks	$ 14.60			0001	Socks			$ 14.60
4	0001	Bib-Shorts	$ 14.60			0001	Bib-Shorts			$ 14.60
5	0001	Shorts	$ 15.00			0001	Shorts			$ 15.00
6	0001	Tights	$ 14.60			0001	Tights			$ 14.60
7
8	0006	Brakes	$ 100.20			0006	Brakes			$ 100.20
9	A123A	Cargo Bike	$ 496.00			A123A	Cargo Bike			$ 496.00
10	A124	Lights	$ 496.00			A124	Lights			$ 496.00
11	A125	Locks	$ 100.20			A125	Locks			$ 100.20
12
13	0007	Jerseys	$ 25.00			0007	Jerseys			$ 25.00
14
15	B123	Pumps	$ 90.00			B123	Pumps			$ 90.00
16	B456	Vests	$ 90.00			B456	Vests			$ 90.00
17	B457	Road Bikes	$ 90.00			B457	Road Bikes			$ 90.00
18	G514	Pedals	$ 90.00			G514	Pedals			$ 90.00
19	123456	Helmets	$ 90.00			123456	Helmets			$ 90.00
Sheet1

 

[Peter_SSs]

What about this then?

Sub AllocateCategories_v2()
  Dim rA As Range
  Dim oSet As Long
  
  Const HdrRow As Long = 1    '<- Header row
  Const PCol As String = "J"  '<- Price column
  Const RCol As String = "O"  '<- Result column
  
  oSet = Columns(PCol).Column - Columns(RCol).Column
  Application.ScreenUpdating = False
  With Range(RCol & HdrRow + 1).Resize(Range(PCol & Rows.Count).End(xlUp).Row - HdrRow)
    .NumberFormat = "000"
    For Each rA In .Offset(, oSet).SpecialCells(xlConstants).Areas
      rA.Offset(, -oSet).FormulaR1C1 = _
        Replace("=IF(COUNTIF(" & rA.Address(, , xlR1C1) & ",RC[#])=1,"""",IFNA(VLOOKUP(RC[#],R" & rA.Row - 1 & "C[#]:R[-1]C,-#+1,0),MAX(R1C:R[-1]C)+1))", "#", oSet)
    Next rA
    .Value = .Value
  End With
  Application.ScreenUpdating = True
End Sub

If the headers will already be in the sheet and in row 1 then instead of editing PCol and RCol in the code, the code could locate the headers itself.
Or if "Category Results" header is not there (but "Price" is) and results were to go in the next available column, that could also be done in the code.

 

[BORUCH]

What about this then?

Sub AllocateCategories_v2()
  Dim rA As Range
  Dim oSet As Long
 
  Const HdrRow As Long = 1    '<- Header row
  Const PCol As String = "J"  '<- Price column
  Const RCol As String = "O"  '<- Result column
 
  oSet = Columns(PCol).Column - Columns(RCol).Column
  Application.ScreenUpdating = False
  With Range(RCol & HdrRow + 1).Resize(Range(PCol & Rows.Count).End(xlUp).Row - HdrRow)
    .NumberFormat = "000"
    For Each rA In .Offset(, oSet).SpecialCells(xlConstants).Areas
      rA.Offset(, -oSet).FormulaR1C1 = _
        Replace("=IF(COUNTIF(" & rA.Address(, , xlR1C1) & ",RC[#])=1,"""",IFNA(VLOOKUP(RC[#],R" & rA.Row - 1 & "C[#]:R[-1]C,-#+1,0),MAX(R1C:R[-1]C)+1))", "#", oSet)
    Next rA
    .Value = .Value
  End With
  Application.ScreenUpdating = True
End Sub

If the headers will already be in the sheet and in row 1 then instead of editing PCol and RCol in the code, the code could locate the headers itself.
Or if "Category Results" header is not there (but "Price" is) and results were to go in the next available column, that could also be done in the code.

Thank you very much it works perfectly !!

thanks again for your time

 

[Peter_SSs]

You're welcome. Thanks for the confirmation.

 

[BORUCH]

You're welcome. Thanks for the confirmation.

Good morning
i was just wondering if i wanted to add an imput box for the header row or price column would it be as simpe as dim aa as string and aa= imput box... ?

 

[Peter_SSs]

would it be as simpe as dim aa as string and aa= imput box... ?

Why not give it a try?

if i wanted to add an imput box for the header row or price column

Why "or"? If we asked one how would we know the other?
Also, are you implying that the Category Results column is now fixed? If not, how would we know where that was?

 

[BORUCH]

Why not give it a try?



Why "or"? If we asked one how would we know the other?
Also, are you implying that the Category Results column is now fixed? If not, how would we know where that was?

Hi

sorry for not being clear i meant to add an input box question for the price column And another input box question for the header row

I would basically look at the sheet and see where those columns are and input them

I actually tried it and i got a "constant expression required"

 

[Peter_SSs]

i meant to add an input box question for the price column And another input box question for the header row

That still leaves my other question

Also, are you implying that the Category Results column is now fixed? If not, how would we know where that was?

 

[BORUCH]

That still leaves my other question

I guess there would need to be a third imput box

 

[Peter_SSs]

Try this

Sub AllocateCategories_v3()
  Dim Bits As Variant
  Dim rA As Range
  Dim oSet As Long, HdrRow As Long
  Dim PCol As String, RCol As String, Resp As String
 
  Resp = InputBox("Enter header row, Price column & Result column separated by commas. eg 1,J,O")
  Bits = Split(Resp, ",")
  If UBound(Bits) = 2 Then
    If Evaluate("isref(" & Bits(1) & Bits(0) & ")") And Evaluate("isref(" & Bits(2) & Bits(0) & ")") Then
      HdrRow = Bits(0)
      PCol = Bits(1)
      RCol = Bits(2)
      oSet = Columns(PCol).Column - Columns(RCol).Column
      Application.ScreenUpdating = False
      With Range(RCol & HdrRow + 1).Resize(Range(PCol & Rows.Count).End(xlUp).Row - HdrRow)
        .NumberFormat = "000"
        For Each rA In .Offset(, oSet).SpecialCells(xlConstants).Areas
          rA.Offset(, -oSet).FormulaR1C1 = _
            Replace("=IF(COUNTIF(" & rA.Address(, , xlR1C1) & ",RC[#])=1,"""",IFNA(VLOOKUP(RC[#],R" & rA.Row - 1 & "C[#]:R[-1]C,-#+1,0),MAX(R1C:R[-1]C)+1))", "#", oSet)
        Next rA
        .Value = .Value
      End With
      Application.ScreenUpdating = True
    Else
      MsgBox "Incorrect input"
    End If
  Else
    MsgBox "Incorrect input"
  End If
End Sub