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

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
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
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
858
Micron
M
J
  • Locked
  • Question Question
Still need help on a daily summary sheet
Replies
1
Views
594
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
S
  • Question Question
VBA import of an IQY file without prompt
Replies
4
Views
1K
John_w
J

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

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