Erweiterung oder VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Hartmut,
meinst du so?
Kabelliste 2018_11_29

	A	B	C	D	E	F
1	Pos	Suchfeld	Hilfsspalte	Ergebnisfeld 1 Kabel	Ergebnisfeld Von	Ergebnisfeld Nach
2	1	d53a	16	DA-F080D53A	++W148+*F080D53A-T:-	++W148+*VB14821002S1-A3:S4-
3	2		17	DA-F080D53A-1	++W148+*F080D53A-1-VC:12	++W148+*VB14821002S1-A3:S5-
4	3		56	DA-F090D53A	++W148+*F090D53A-T:-	++W148+*VB14821002S1-A1:S1-
5	4		57	DA-F090D53A-1	++W148+*F090D53A-1-VC:12	++W148+*VB14821002S1-A1:S2-
6	5
7	6
8	7
9	8

Formeln der Tabelle

Zelle	Formel
C2	=WENNFEHLER(AGGREGAT(15;6;ZEILE($A$1:$A$19999)/(ISTZAHL(SUCHEN($B$2;G$2:G$20000))); ZEILE($A1)); "")
D2	=WENN($C2="";"";INDEX(G$2:G$20000;$C2))
E2	=WENN($C2="";"";INDEX(H$2:H$20000;$C2))
F2	=WENN($C2="";"";INDEX(I$2:I$20000;$C2))

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
Das geht am einfachsten mit einer Hilfsspalte.
https://www.herber.de/bbs/user/126024.xlsx

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Hallo Hartmut,
freut mich, dass es klappt!
Hier der Code mit ein paar Kommentaren.
Private Sub Worksheet_Change(ByVal Target As Range) Dim varSearch As Variant, varOut() As Variant, varItem As Variant Dim rng As Range, rngS As Range, lngRow() As Long, strFirst As String Dim lngLast As Long, lngIndex As Long, lngCount As Long 'Fehlerbehandlung On Error GoTo ErrorHandler If Not Intersect(Target, Range("C:C")) Is Nothing Then 'wenn Änderung in Spalte C Application.EnableEvents = False 'Event-gesteuerte Makros deaktivieren, damit sich der Code nicht selber aufruft With Me Set rngS = .Range("G:I") 'Suchbereich definieren lngLast = Application.Max(3, .Cells(.Rows.Count, 3).End(xlUp).Row) 'letzte Zeile der Suchbegriffe ermitteln If lngLast = 2 Then Redim varSearch(1 To 1, 1 To 1) varSearch(1, 1) = .Range("C2") Else varSearch = .Range("C2:C" & lngLast) 'Suchbegriffe in ein Array einlesen End If .Range("C2:B" & lngLast) = "" 'Suchbegriffe leeren varSearch = toArrayUnique(varSearch) 'Array mit den Suchbegriffen bereinigen. Keine Doppelten! lngLast = Application.Max(2, .Cells(.Rows.Count, 7).End(xlUp).Row) 'letzte Zeile im Datenbereich bestimmen Redim varOut(1 To lngLast - 1, 1 To 5) 'Ausgabearray dimensionieren For Each varItem In varSearch 'Suchbegrife durchlaufen strFirst = "": Erase lngRow: Redim lngRow(0): lngCount = 0 'Hilfsvariablen leeren/reseten If Len(Trim(varItem)) Then 'Suchbegriff im Suchbereich suchen Set rng = rngS.Find(What:=varItem, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False, _ SearchFormat:=False, SearchDirection:=xlNext, After:=rngS.Cells(1, 1)) If Not rng Is Nothing Then 'wenn Treffer strFirst = rng.Address 'Addresse des erten Treffers merken Do 'Suchschleife If IsError(Application.Match(rng.Row, lngRow, 0)) Then 'Wenn noch kein Treffer in der selben Zeile Redim Preserve lngRow(lngCount) 'Hilfsarray der Zeilennummern redimensionieren lngRow(lngCount) = rng.Row 'Zeilennummer des Treffers in das Hilfsarra schreiben lngCount = lngCount + 1 'Zähler hochzählen lngIndex = lngIndex + 1 '... varOut(lngIndex, 1) = varItem 'Suchbegriff in ertse Spalte das Ausgabe-Arrays schreiben für blockweise markierung If lngCount = 1 Then varOut(lngIndex, 2) = varItem 'Suchbegriff in erste Zeile der Trefferliste in zweite Spalte schreiben varOut(lngIndex, 3) = rngS.Cells(rng.Row, 1) 'Treffer in das Ausgabe-Array schreiben varOut(lngIndex, 4) = rngS.Cells(rng.Row, 2) '... varOut(lngIndex, 5) = rngS.Cells(rng.Row, 3) '... End If Set rng = rngS.FindNext(rng) 'weitersuchen Loop While Not rng Is Nothing And strFirst <> rng.Address 'Abbruchkriterien prüfen End If End If Next .Range("B2").Resize(Ubound(varOut, 1), 5) = varOut 'Ausgabe-Array in die Tabelle schreiben End With End If 'Fehlerbehandlung ErrorHandler: Application.EnableEvents = True 'Event-gesteuerte Makros wieder aktivieren End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Beliebteste Forumthreads (12 Monate)

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread