Zahlengruppen vergleichen VBA

Hallo,
Habe hier ein schweres Problem (für mich).
Aus dem Archiv habe ich mir nichts passendes zusammenbauen können.
Vielleicht kann mir hier jemand helfen.
https://www.herber.de/bbs/user/57492.xls
Die Zahlengruppe in Spalte A soll mit der Zahlengruppe in Tabelle2 A verglichen werden.
Wenn eine Zahl gefunden wird, soll in Spalte B für jede gefunden Zahl eine 1 addiert werden.
Also, Zahl wieviel mal gefunden. Beispiel in Spalte K
Die Schwierigkeit ist Zeile 9 und Zeile 13.
Mehrere Zahlen in einer Zelle mit "/" getrennt. Bis 4 Zahlen in einer Zelle
Diese Zahlen müssen nicht einzeln gezählt werden, es reicht die Anzahl wieviel mal gefunden.
Das Ganze müsste ich in VBA haben, da die Daten in VBA weiterverarbeitet werden.
Sicher müsste das in einer Schleife laufen (bis 4 Zahlen in einer Zelle!) ,aber ich hab keine Ahnung wie.
Danke für jede Hilfe
marion

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Makro1() With Range("C2:C14") .Formula = "=COUNTIF(Tabelle2!$A$2:$A$22,--LEFT(A2,5))" _ & "+IF(LEN(A2)>10,COUNTIF(Tabelle2!$A$2:$A$22,--MID(A2,7,5)),0)" _ & "+IF(LEN(A2)>16,COUNTIF(Tabelle2!$A$2:$A$22,--MID(A2,13,5)),0)" _ & "+IF(LEN(A2)>22,COUNTIF(Tabelle2!$A$2:$A$22,--MID(A2,19,5)),0)" .Formula = .Value End With End Sub

Sub Auswerten() Dim Zelle1 As Range Dim Zelle2 As Range Dim Bereich1 As Range Dim Bereich2 As Range With Worksheets("Tabelle2") Set Bereich1 = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)) End With With Worksheets("Tabelle1") Set Bereich2 = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)) End With For Each Zelle1 In Bereich1 For Each Zelle2 In Bereich2 If InStr(1, CStr(Zelle2.Value), CStr(Zelle1.Value)) > 0 Then _ Zelle2.Offset(0, 1).Value = Zelle2.Offset(0, 1).Value + 1 Next Zelle2 Next Zelle1 End Sub

...mir nicht einsichtig ist, Marion,
warum das unbedingt mit VBA erfolgen soll. Da ja die Zählwerte ohnehin in Spalte B eingetragen wdn sollen, ist doch anzunehmen, dass die weiterverarbeitende Prozedur genau auf diese Spalte zugreift. Also könntest du auch Formeln verwenden! Wenn nicht dein spezielles Problem wäre, könntest du das mit ZÄHLENWENN lösen. So muss für die Kombizahlen erst ein Wertefeld erzeugt wdn. Dafür gibt's in www.excelformeln.de bestimmt eine reine Standardformellösung, die wahrscheinlich recht kompliziert anmutet... ;-)
Deshalb stelle ich dir hier mal eine auf das Nötigste reduzierte udFkt ein (Umsetzung der vbFkt Split), die du in einer Tabellenfml einsetzen kannst (in ein Standardmodul des VBA-Projektes oder einer stets gleichzeitig geöffneten Makro-Sammlung bzw eines AddIns kopieren!).


Function Splitt(Bezug, ByVal Trenner As String)
Splitt = Split(Bezug, Trenner)
End Function

Diese kannst du in der folgenden einzelligen Matrixformel (zur speziellen Eingabe solcher Fml b.Bedarf in der xlHilfe nachlesen!), die zur Voraussetzung hat, dass die Zahlen im korrespondierenden Bereich von Tabelle2 einzeln auftreten (auf Grund deiner doch recht guten Beschreibung des Problems habe ich auf einen Download verzichtet!), einsetzen (Fml nach unten kopieren!)...
{=SUMME(--(--Splitt(Tabelle1!A1;"/") =Tabelle2!A$1:A$20))} → deine_bezüge!
Dabei haben die Doppelminus die Aufgabe, Textzahlen bzw Wahrheitswerte in echte Zahlen zu verwandeln. Ersatzweise könntest du auch jeweils mit 1 multiplizieren oder 0 addieren.
Übrigens kannst du die udFkt natürlich auch für analoge Aufgaben wiederverwenden - auch mit >4 Zahlen in einer Zelle - also keine "Insellösung"... ;-)
Gruß Luc :-?

Sub GleicheZählen() Dim i As Long, z() As Long, y, _ vb As Range, x As Range, zb As Range Const Trenner As String = "/", VBer As String = "A1:A12", _ VBl As String = "Tabelle2", ZBer As String = "A1:A10", _ ZBl As String = "Tabelle1" With ActiveWorkbook Set vb = .Sheets(VBl).Range(VBer) Set zb = .Sheets(ZBl).Range(ZBer) End With ReDim z(zb.Count - 1) As Long For Each x In zb With WorksheetFunction If CBool(InStr(x, Trenner)) Then For Each y In Split(x, Trenner) z(i) = z(i) + .CountIf(vb, y) Next y Else: z(i) = .CountIf(vb, x) End If End With i = i + 1 Next x zb.Offset(0, 1) = WorksheetFunction.Transpose(z) 'Sp.B nur für Test End Sub

Beliebteste Forumthreads (12 Monate)

	A	B	C
1		gefunden
2	23301	2	2
3	21124	1	1
4	20681	1	1
5	29580	0	0
6	20948	3	3
7	30943	1	1
8	34567	2	2
9	24653/52410/46670/12345	5	5
10	26093	0	0
11	22522	1	1
12	24433	2	2
13	22761/28492	3	3
14	23054	0	0

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread