VBA Count and paste value

S

shelim481

New Member
Joined
Aug 30, 2018
Messages
28
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?
 
Sort by date Sort by votes
I modified it for my needs and it works, just one last thing, how would i use this columns instead of rows, so say group, name and number was arranged in columns... ??
 
Upvote 0

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Change the ranges so that it is looking at a row, rather than a column.
 
Upvote 0
i tried this but it not working...


On Error Resume Next
For Each rng In Range("G1", Range("2" & Columns.Count).End(xlToLeft).Offset(, -1)).SpecialCells(xlBlanks).Areas


Range("T" & Cells(Rows.Count, "T").End(xlUp).Row + 1).Value = rng.Count + 1



Next rng

On Error GoTo 0
For Each rng In Range("G1", Range("2" & Columns.Count).End(xlToLeft).Offset(, -1)).SpecialCells(xlConstants).Areas

If rng.Count > 1 Then
For i = 1 To rng.Count



Range("T" & Cells(Rows.Count, "T").End(xlUp).Row + 1).Value = 1


Next i
End If
Next rng
 
Upvote 0
Can you post what your data looks like please.
 
Upvote 0
[TABLE="width: 512"]
<tbody>[TR]
[TD="class: xl63, width: 64"]TY1[/TD]
[TD="class: xl63, width: 64"][/TD]
[TD="class: xl63, width: 64"][/TD]
[TD="class: xl63, width: 64"][/TD]
[TD="class: xl63, width: 64"]TY2[/TD]
[TD="class: xl63, width: 64"][/TD]
[TD="class: xl63, width: 64"]TY3[/TD]
[TD="class: xl63, width: 64"][/TD]
[/TR]
[TR]
[TD="class: xl63"]123[/TD]
[TD="class: xl63"]32[/TD]
[TD="class: xl63"]43[/TD]
[TD="class: xl63"]54[/TD]
[TD="class: xl63"]7667[/TD]
[TD="class: xl63"]765[/TD]
[TD="class: xl63"]765[/TD]
[TD="class: xl63"]567[/TD]
[/TR]
</tbody>[/TABLE]


so it should give 4,2,2

I got the below code partially working but it gives some weird last numbers
Code: 
    On Error Resume Next
    For Each rng In Range("G1", Range("G2" & Columns.Count).End(xlToRight).Offset(, -1)).SpecialCells(xlBlanks).Areas


    Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = rng.Count + 1
   


    Next rng
    
    On Error GoTo 0
    For Each rng In Range("G1", Range("G2" & Columns.Count).End(xlToRight).Offset(, -1)).SpecialCells(xlConstants).Areas
    
      If rng.Count > 1 Then
         For i = 1 To rng.Count
         
  
         
             'Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = 1


         Next i
      End If
      Next rng
 
Last edited:
Upvote 0
Assuming that TY1 is in G1 try
Code: 
Sub shelim481()
   Dim rng As Range
   Dim i As Long
   On Error Resume Next
   For Each rng In Range("G1", Cells(2, Columns.Count).End(xlToLeft).Offset(-1)).SpecialCells(xlBlanks).Areas
      rng.Offset(2, -1).Resize(, 1).Value = rng.Count + 1
   Next rng
   On Error GoTo 0
   For Each rng In Range("G1", Cells(2, Columns.Count).End(xlToLeft).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
 
Upvote 0
Hi


found a big error with the macro, please help, basically when you have bunch of multiple groups then at the end only have a group of 1 it does not show for the last one...
Code: 
[COLOR=#333333]Sub shelim481()[/COLOR]   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 [COLOR=#333333]End Sub[/COLOR]

[TABLE="width: 192"]
<colgroup><col width="64" span="3" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Group[/TD]
[TD="width: 64"]Name [/TD]
[TD="width: 64"]Number[/TD]
[/TR]
[TR]
[TD]fdf[/TD]
[TD]sdsa[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]fdf[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]dsad[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]fdf[/TD]
[TD]sdsa[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]gfgdg[/TD]
[TD]gfddgfd[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]dfgfdgfd[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD="colspan: 2"]fddgddfgfd[/TD]
[/TR]
[TR]
[TD]fds[/TD]
[TD]gfdgfd[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]fd[/TD]
[TD]gfdgfd[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]gfd[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]dfgfdgfd[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]fdgfd[/TD]
[TD]g[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


the last one does not show...any ideas?
 
Upvote 0
How about
Code: 
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
      Debug.Print Rng.Address
      If Rng.Count > 1 Then
         For i = 1 To Rng.Count - 1
            Rng(i).Offset(, 2) = 1
         Next i
      End If
      If Rng.Offset(Rng.Count - 1).Resize(1).Address = Range("B" & Rows.Count).End(xlUp).Offset(, -1).Address Then
         Rng.Offset(, 2) = 1
      End If
   Next Rng
End Sub
 
Upvote 0
that works now under all circumstances, im trying to change the column one, but keep getting errors could you have a look please...

Code: 
    For Each rng In Range("G1", Cells(2, Columns.Count).End(xlToLeft).Offset(-1)).SpecialCells(xlBlanks).Areas    rng.Offset(2, -1).Resize(, 1).Value = rng.Count + 1
    Next rng
    On Error GoTo 0
    For Each rng In Range("G1", Cells(2, Columns.Count).End(xlToLeft).Offset(-1)).SpecialCells(xlConstants).Areas
      Debug.Print rng.Address
      If rng.Count > 1 Then
         For i = 1 To rng.Count - 1
            rng(i).Offset(2) = 1
         Next i
      End If
            If rng.Offset(rng.Count - 1).Resize(1).Address = Range(2, Columns.Count).End(xlToLeft).Offset(-1).Address Then
         rng.Offset(, 2) = 1
      End If
    Next rng
 
Upvote 0
Try
Code: 
      If Rng.Offset(, Rng.Count - 1).Resize(, 1).Address = Cells(2, Columns.Count).End(xlToLeft).Offset(-1).Address Then
         Rng.Offset(2) = 1
      End If
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
VBA to allow grouping +- after reopening of the sheet
Replies
7
Views
2K
Greenbehindthecells
G
W
  • Solved
VBA - Match two values from Table1 to two in Table2 and move/align
2
Replies
15
Views
376
Welshy1491
W
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
J
  • Locked
  • Question Question
Still need help on a daily summary sheet
Replies
1
Views
606
Fluff
Fluff
B
  • Question Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
1K
Alex Blakenburg
A

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top