VBA Count and paste value

[shelim481]

Hi im trying to find out how to count the numbers in each group, using macro instead of formula, the group go on for as many as needed, i want it so that it does number part for me...once i have filed out group and name...



[TABLE="width: 500"]
<tbody>[TR]
[TD]Group[/TD]
[TD]Name[/TD]
[TD]Number[/TD]
[/TR]
[TR]
[TD]G1[/TD]
[TD]ASJ[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]ATT[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]G2[/TD]
[TD]AMM[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]MKK[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]TST[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]ST2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]G3[/TD]
[TD]RT4[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]YT4[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]MK[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
And So forth....



Any ideas?

 

[JackDanIce]

Save a copy of your file and then try:

Sub M1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    
    x = Cells(Rows.Count, 2).End(xlUp).Row
    arr = Cells(1, 1).Resize(x, 3).Value
    
    For x = UBound(arr, 1) To LBound(arr, 1) + 1 Step -1
        y = y + 1
        If Len(arr(x, 1)) > 0 Then
            arr(x, 3) = y
            y = 1
        End If
    Next x
    
    Cells(1, 1).Resize(UBound(arr, 1), 3).Value = arr
    
    Erase arr

End Sub

This assumes your data starts in A1, has headers and column B defines the last used row for the table

 

[Fluff]

Another option

Sub shelim481()
   Dim Rng As Range
   For Each Rng In Range("A2", Range("B" & Rows.Count).End(xlUp).Offset(, -1)).SpecialCells(xlBlanks).Areas
      Rng.Offset(-1, 2).Resize(1).Value = Rng.Count + 1
   Next Rng
End Sub

 

[shelim481]

awesome thanks...they both worked...

 

[Fluff]

Glad we could help & thanks for the feedback

 

[shelim481]

just noticed something when group and name are one the number does not show, any ideas.. ?

 

[Fluff]

Ok, how about

Sub shelim481()
   Dim rng As Range
   Dim i As Long
   For Each rng In Range("A2", Range("B" & Rows.Count).End(xlUp).Offset(, -1)).SpecialCells(xlBlanks).Areas
      rng.Offset(-1, 2).Resize(1).Value = rng.Count + 1
   Next rng
   For Each rng In Range("A2", Range("B" & Rows.Count).End(xlUp).Offset(, -1)).SpecialCells(xlConstants).Areas
      If rng.Count > 1 Then
         For i = 1 To rng.Count - 1
            rng(i).Offset(, 2) = 1
         Next i
      End If
   Next rng
End Sub

 

[shelim481]

legend that worked a treat...

 

[shelim481]

sorry about this, but now i realised if all the groups are only one, i get error message no cells found...

 

[Fluff]

Try

Sub shelim481()
   Dim rng As Range
   Dim i As Long
   On Error Resume Next
   For Each rng In Range("A2", Range("B" & Rows.Count).End(xlUp).Offset(, -1)).SpecialCells(xlBlanks).Areas
      rng.Offset(-1, 2).Resize(1).Value = rng.Count + 1
   Next rng
   On Error GoTo 0
   For Each rng In Range("A2", Range("B" & Rows.Count).End(xlUp).Offset(, -1)).SpecialCells(xlConstants).Areas
      If rng.Count > 1 Then
         For i = 1 To rng.Count - 1
            rng(i).Offset(, 2) = 1
         Next i
      End If
   Next rng
End Sub