Zählen in aktiven Spalten (VBA)

Hallo Zusammen,
ich bin auf der Suche nach einem VBA-Code, der mir die Anzahl (in meinem Beispiel ist es das "A") in den aktivten Spalten zählt.
Folgendes muss passieren.
Ich markiere mehrere Zellen in einer Zeile und klicke auf den Button "Schaltfläche 1".
Dadurch werden in allen markierten Zellen der Buchstabe "A" eingetragen. Nun ist es aber so, dass eine msgbox aufpoppen soll, wenn von der gleichen Nr (Spalte A) das "A" mehrmals am selben Tag vorkommt. In der angehängten Datei wäre es an folgenden Tagen.
Tag2: hier kommt das "A" bei der Nr. 100 4 x vor
Tag6: hier kommt das "A" bei der Nr. 400 3 x und bei der Nr. 200 2 x vor.
Tag8: hier kommt das "A" bei der Nr. 100 4 x vor
Wie oft das bei der jeweiligen Nr. vorkommen darf, hängt von der Zahl in Spalte R ab.
Hoffentlich findet ihr eine Lösung für mein Problem.
Anbei dei xls
https://www.herber.de/bbs/user/157283.xlsm
Gruß Josef

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Anzahl_A() Dim D1 As Object Dim D2 As Object Dim R, C, K Dim Sp As Long Dim Msg As String Set D1 = CreateObject("Scripting.Dictionary") With Worksheets("Tabelle2") 'Beschränkung sammeln For Each R In .Range("F14:F25") D1(R.Value) = R.Offset(0, 1).Value Next End With With Worksheets("Tabelle1") 'Tage durchgehen For C = 2 To .Range("A1").End(xlToRight).Column Set D2 = CreateObject("Scripting.Dictionary") 'einzelne Einträge sammeln For R = 2 To .Range("A65535").End(xlUp).Row If .Cells(R, C).Value = "A" Then D2(.Cells(R, 1).Value) = D2(.Cells(R, 1).Value) + 1 Next 'ggü Maxwert prüfen For Each K In D2.keys If D2(K) >= D1(K) Then Msg = Msg & vbLf & "Tag" & C - 1 & ", " & K & ": " & D2(K) Next Next If Len(Msg) > 1 Then MsgBox Msg End With End Sub

Hallo Josef
wie ich sehe gibt es eine Lösung von Yal. Sein Code ist sicher moderner, und schneller.
Meinen Code habe ich auf Tabelle2 umgeschrieben. Er hat einige Besonderheiten.
In Tabelle1 gibt es kein Limit für Spalten oder Zeilen. Das Makro findet LastZell und LastColumn!
Wenn du den Bereich "F14:G25" in Tabelle2 verschieben willst/ musst, ist das auch kein Problem.
Im Makro steht eine Const Anweisung mit der ersten Zelle "F14". Da musst du nur die Adresse aendern!
mfg Piet

Option Explicit 'überarbeitet: 16.1.2023 Piet für Herber Forum
Dim AC As Range, lz1 As Long
Dim AF As Range, lzF As Long
Dim sp As Integer, lsp As Integer
Dim Wert As Integer, Txt As String
Const MaxAdr = "F14" '1. Zelle Max Wert


Sub Anzahl_A_zählen()
Dim Tb2 As Worksheet, rw 'Max
Dim n As Integer, x As Integer
Set Tb2 = Worksheets("Tabelle2")
With Worksheets("Tabelle1")
lz1 = .Range("A1").End(xlDown).Row
lsp = .Range("A1").End(xlToRight).Column
lzF = Tb2.Range(MaxAdr).End(xlDown).Row
lzF = lzF - Tb2.Range(MaxAdr).Row + 1
'Spalten B-L auswählen  (können mehr sein!)
For sp = 2 To lsp
'Max Werte aus Spalte F laden
Txt = Empty  'Auswertung löschen
For Each AF In Tb2.Range(MaxAdr).Resize(lzF, 1)
Wert = AF.Value:  n = 0
x = AF.Cells(1, 2).Value
'Spalten B-L > Max durchsuchen
For Each AC In .Range("A2:A" & lz1)
If AC.Value = AF.Value And _
.Cells(AC.Row, sp) = "A" Then n = n + 1
Next AC
If n > x Then Txt = Txt & Wert & " > " & x & " = " & n & vbLf
Next AF
'Auswertung > Max. für jeden Tag einzeln anzeigen
If Txt  Empty Then MsgBox .Cells(1, sp) & vbLf & Txt
Next sp
End With
End Sub

Sub Anzahl_A() Dim D1 As Object Dim D2 As Object Dim R, C, K Dim Sp As Long Dim Msg As String Set D1 = CreateObject("Scripting.Dictionary") With Worksheets("Tabelle2") 'Beschränkung sammeln For Each R In .Range("F14:F25") D1(R.Value) = R.Offset(0, 1).Value Next End With With Worksheets("Tabelle1") 'Tage durchgehen For Each C In Selection.Columns Set D2 = CreateObject("Scripting.Dictionary") 'einzelne Einträge sammeln For R = 2 To .Range("A65535").End(xlUp).Row If .Cells(R, C).Value = "A" Then D2(.Cells(R, 1).Value) = D2(.Cells(R, 1).Value) + 1 Next 'ggü Maxwert prüfen For Each K In D2.keys If D2(K) >= D1(K) Then Msg = Msg & vbLf & "Tag" & C - 1 & ", " & K & ": " & D2(K) Next Next If Len(Msg) > 1 Then MsgBox Msg End With End Sub

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zählen in aktiven Spalten (VBA)

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread