count shapes for list names automatically instead of manually

[Mussa]

hello

I have this macro works very well when I write specific names it will add oval shape for entire row contains items or values for each name and it will count the oval shape into column N based on column M for each name , but I have to write them manually to count them . so what I want justl little adjusting for the code . should show the names in column M automatically when run the macro . and should replace the data when show the names or count them every time run the macro.

Public Sub AddRedOva3()
Dim Shp As Shape
Dim rg As Range, c As Range, fnd As Range, tRow As Long
Dim Value As Variant, t() As String
Application.ScreenUpdating = False
For Each Shp In ActiveSheet.Shapes
    If Shp.Name <> "Button 1" Then Shp.Delete
Next Shp
For Each c In Range("N2:N" & Cells(Rows.Count, "N").End(xlUp).Row)
    c = 0
Next c
 
Application.ScreenUpdating = True
  Value = InputBox("Enter Value:", "Input")
  t = Split(Value, ",")
  lastrow = Range("B" & Rows.Count).End(xlUp).Row
  Set rg = Sheets("sheet1").Range("B2:J" & lastrow)
For i = 0 To UBound(t)
    invalue = t(i)
    GoSub update_Counter
    For r = 1 To lastrow
        If rg(r, 1) <> "" And rg(r, 1) = invalue Then
            For col = 1 To 9
                Set c = rg(r, col)
                If c <> "" Then
                    Set Shp = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height)
                    Shp.Fill.Transparency = 1
                    Shp.Line.ForeColor.RGB = RGB(255, 0, 0)
                    Shp.Line.Weight = 1
                    If tRow > 0 Then Cells(tRow, "N") = Cells(tRow, "N") + 1
                End If
            Next col
        End If
    Next r
  Next i
Exit Sub

update_Counter:
With Range("M:M")
    Set fnd = .Find(What:=invalue, LookIn:=xlValues, Lookat:=xlWhole)
    If Not fnd Is Nothing Then
        tRow = fnd.Row
    Else
    End If
End With
Return
End Sub

 

[shknbk2]

should show the names in column M automatically when run the macro

Is something like this what you are thinking?

    Dim a As Variant, sTemp As String, i As Integer
    
    a = Range("M2:M" & Cells(Rows.Count, "M").End(xlUp).Row).Value
    For i = 1 To UBound(a)
        sTemp = sTemp & a(i, 1) & ","
    Next
    sTemp = Left(sTemp, Len(sTemp) - 1)
    Value = InputBox("Enter Value:", "Input", sTemp)

should replace the data when show the names or count them every time run the macro

I am not sure what you want here. What data should be replaced?

 

[Mussa]

where I put your suggestion ? may you update the whole code to show how works ,please?

 

[shknbk2]

Sure.

Public Sub AddRedOva3()
    Dim Shp As Shape
    Dim rg As Range, c As Range, fnd As Range, tRow As Long
    Dim Value As Variant, t() As String
    
    Application.ScreenUpdating = False
    For Each Shp In ActiveSheet.Shapes
        If Shp.Name <> "Button 1" Then Shp.Delete
    Next Shp
    For Each c In Range("N2:N" & Cells(Rows.Count, "N").End(xlUp).Row)
        c = 0
    Next c
    
    Application.ScreenUpdating = True
    
    Dim a As Variant, sTemp As String, i As Integer
    
    a = Range("M2:M" & Cells(Rows.Count, "M").End(xlUp).Row).Value
    For i = 1 To UBound(a)
        sTemp = sTemp & a(i, 1) & ","
    Next
    sTemp = Left(sTemp, Len(sTemp) - 1)
    If sTemp = "" Then Exit Sub
    
    Value = InputBox("Enter Value:", "Input", sTemp)
    
    t = Split(Value, ",")
    LastRow = Range("B" & Rows.Count).End(xlUp).Row
    Set rg = Sheets("sheet1").Range("B2:J" & LastRow)
    For i = 0 To UBound(t)
        invalue = t(i)
        GoSub update_Counter
        For r = 1 To LastRow
            If rg(r, 1) <> "" And rg(r, 1) = invalue Then
                For col = 1 To 9
                    Set c = rg(r, col)
                    If c <> "" Then
                        Set Shp = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height)
                        Shp.Fill.Transparency = 1
                        Shp.Line.ForeColor.RGB = RGB(255, 0, 0)
                        Shp.Line.Weight = 1
                        If tRow > 0 Then Cells(tRow, "N") = Cells(tRow, "N") + 1
                    End If
                Next col
            End If
        Next r
    Next i
    Exit Sub

update_Counter:
    With Range("M:M")
        Set fnd = .Find(What:=invalue, LookIn:=xlValues, Lookat:=xlWhole)
        If Not fnd Is Nothing Then
            tRow = fnd.Row
        End If
    End With
    Return
End Sub

 

[Mussa]

thanks , unfortunately it doesn't work . what I want after write name or more into inputbox based on orginal code and when add oval shap should show the names which contains oval shape in column M and count in column N , but based on code I have to write the names manually .

short of words , should show names contains oval shape in column M without interfere from me .

 

[shknbk2]

What is an example of the text you put in the InputBox?

 

[Mussa]

orginal data

COUNT.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	DATE	NAME	INV NO	ORDER NO	BRAND	M-SIZ	PRR	CASE	DEBIT	CREDIT			NAME	COUNT
2	1/10/2019	MUSSA	INV-BU1000	ARR-1	FOOD1	MS-100	RPP-1	PA	12,000.00	200.00			MUSSA	-
3	1/11/2019	MUSS	INV-BU1001	ARR-2	FOOD2	MS-101	RPP-2	NO PA	1,000.00				MUSS	-
4	1/12/2019	MUSSA3	INV-BU1002	ARR-3	FOOD3	MS-102	RPP-3	NO PA	20,000.00				MUSSIA	-
5	1/13/2019	MUSSA4	INV-BU1003	ARR-4	FOOD4	MS-103	RPP-4	NO PA	10,000.00				MUSSA3	-
6	1/14/2019	MUSSA5	INV-BU1004	ARR-5	FOOD5	MS-104	RPP-5	NO PA	30,000.00				MUSSA4	-
7	1/15/2019	MUSSA6	INV-BU1005	ARR-6	FOOD6	MS-105	RPP-6	NO PA	20,000.00				MUSSA5	-
8	1/16/2019	MUSSA7	INV-BU1006	ARR-7	FOOD7	MS-106	RPP-7	NO PA	70,000.00				MUSSA6	-
9	1/17/2019	MUSSA8	INV-BU1007	ARR-8	FOOD8	MS-107	RPP-8	NO PA	12,000.00				MUSSA7	-
10	1/18/2019	MUSSA9	INV-BU1008	ARR-9	FOOD9	MS-108	RPP-9	NO PA	1,000.00				MUSSA8	-
11	1/20/2019	MUSSA10	INV-BU1010	ARR-11	FOOD11	MS-110	RPP-1	NO PA	3,000.00				MUSSA9	-
12	1/21/2019	MUSSA11	INV-BU1011	ARR-12	FOOD12	MS-111	RPP-2	NO PA	4,000.00				MUSSA10	-
13	1/22/2019	MUSSIA	INV-BU1012	ARR-13	FOOD13	MS-112	RPP-3	PA	20,000.00	100.00			MUSSA11	-
14	1/23/2019	MUSSA13	INV-BU1013	ARR-14	FOOD14	MS-113	RPP-4	NO PA	90,000.00				MUSSA13	-
15	1/24/2019	MUSSA14	INV-BU1014	ARR-15	FOOD15	MS-114	RPP-5	NO PA	100,000.00				MUSSA14	-
16	1/25/2019	MUSSA	INV-BU1015	ARR-16	FOOD16	MS-103	RPP-6	NO PA	4,000.00
17	1/26/2019	MUSS	INV-BU1016	ARR-17	FOOD17	MS-116	RPP-17	NO PA	6,000.00
18	1/27/2019	MUSSA10	INV-BU1000	ARR-1	FOOD1	MS-100	RPP-18	NO PA	3,000.00
sheet1

fill names into inputbox

the result

new requirements .see the column M

before run the code

COUNT.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N
1	NAME	INV NO	ORDER NO	BRAND	M-SIZ	PRR	CASE	DEBIT	CREDIT			NAME	COUNT
2	MUSSA	INV-BU1000	ARR-1	FOOD1	MS-100	RPP-1	PA	12,000.00	200.00				-
3	MUSS	INV-BU1001	ARR-2	FOOD2	MS-101	RPP-2	NO PA	1,000.00
4	MUSSA3	INV-BU1002	ARR-3	FOOD3	MS-102	RPP-3	NO PA	20,000.00
5	MUSSA4	INV-BU1003	ARR-4	FOOD4	MS-103	RPP-4	NO PA	10,000.00
6	MUSSA5	INV-BU1004	ARR-5	FOOD5	MS-104	RPP-5	NO PA	30,000.00
7	MUSSA6	INV-BU1005	ARR-6	FOOD6	MS-105	RPP-6	NO PA	20,000.00
8	MUSSA7	INV-BU1006	ARR-7	FOOD7	MS-106	RPP-7	NO PA	70,000.00
9	MUSSA8	INV-BU1007	ARR-8	FOOD8	MS-107	RPP-8	NO PA	12,000.00
10	MUSSA9	INV-BU1008	ARR-9	FOOD9	MS-108	RPP-9	NO PA	1,000.00
11	MUSSA10	INV-BU1010	ARR-11	FOOD11	MS-110	RPP-1	NO PA	3,000.00
12	MUSSA11	INV-BU1011	ARR-12	FOOD12	MS-111	RPP-2	NO PA	4,000.00
13	MUSSIA	INV-BU1012	ARR-13	FOOD13	MS-112	RPP-3	PA	20,000.00	100.00
14	MUSSA13	INV-BU1013	ARR-14	FOOD14	MS-113	RPP-4	NO PA	90,000.00
15	MUSSA14	INV-BU1014	ARR-15	FOOD15	MS-114	RPP-5	NO PA	100,000.00
16	MUSSA	INV-BU1015	ARR-16	FOOD16	MS-103	RPP-6	NO PA	4,000.00
sheet1

after

hope this help to understand me

 

[shknbk2]

Thank you. This explanation was very clear. I think this will be what you need.

Public Sub AddRedOva3()
    Dim Shp As Shape
    Dim rg As Range, c As Range, fnd As Range
    Dim tRow As Long, lastrow As Long
    Dim i As Integer, r As Integer, col As Integer
    Dim Value As Variant, t() As String, invalue As String
   
    Application.ScreenUpdating = False
    For Each Shp In ActiveSheet.Shapes
        If Shp.Name <> "Button 1" Then Shp.Delete
    Next Shp
    Range("M1").CurrentRegion.Offset(1, 0).ClearContents
   
    Value = InputBox("Enter Value:", "Input")
    If Value = "" Then Exit Sub
    t = Split(Value, ",")
    lastrow = Range("B" & Rows.Count).End(xlUp).Row
    Set rg = Sheets("sheet1").Range("B2:J" & lastrow)
    For i = 0 To UBound(t)
        invalue = Trim(t(i))
        tRow = Range("M" & Rows.Count).End(xlUp).Row + 1
        Cells(tRow, 13).Value = t(i)
       
        For r = 1 To lastrow
            If rg(r, 1) <> "" And rg(r, 1) = invalue Then
                For col = 1 To 9
                    Set c = rg(r, col)
                    If c <> "" Then
                        Set Shp = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height)
                        Shp.Fill.Transparency = 1
                        Shp.Line.ForeColor.RGB = RGB(255, 0, 0)
                        Shp.Line.Weight = 1
                        If tRow > 0 Then Cells(tRow, "N") = Cells(tRow, "N") + 1
                    End If
                Next col
            End If
        Next r
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Mussa]

fantastic ! this is what I want .
many thanks