Excel VBA Automatischer Listenvergleich?
Hallo zusammen,
ich hoffe es kann mir jemand weiterhelfen, da ich mit meinem Latein langsam, aber sich am Ende bin.
Ich habe eine Mappe, wobei sich in der ersten Tabelle eine "Gesamtübersicht" aller Objekte befindet (Hardwarekomponenten). Tabelle 2 bis 5 sind jeweils die einzelnen Bestandstabellen - welche sich alle 6 Monate ändern, mit deren Inhalt die "Gesamttabelle" gefüllt werden soll (Bps. Tabelle 2 sind alle GPU's und CPU's, Tabelle 3 PU's... etc). (Siehe Bild)
Nun möchte ich letztlich ein Makro schreiben, welches vollautomatisch die Gesamttabelle aktualisiert, wenn ich eine neue Bestandstabelle einspiele.
Vielen Dank vorab für Lösungsvorschläge oder Denkanstöße zur Umsetzung !
LG
3 Antworten
Hallo,
Oubyi's Formel würde (nach Anpassen der Bezüge) in deiner Beispieldatenoriginaltabelle auch funktionieren. Über $A3&" "&B$2 werden Firma und Hardwarekomponente zusammengesetzt, über Vergleich() in die entsprechende Zeilenposition in Tabelle2 umgewandelt und mit dieser gibt Index() die Anzahl aus. Da du allerdings mehrere Tabellenblätter für die einzelnen Komponenten hast, bräuchtest du für jedes jeweils eine entsprechend angepasste Formel.
Nach demselben Prinzip funktioniert dieser Code. Zum Auslösen würde ich persönlich allerdings einen Button verwenden, anstatt ihn automatisch bei einer Änderung auszulösen:
Sub GesamtObjekte()
Dim ProBlaNum() As Long
Dim ProNam() As String
Dim fehlt As Boolean
Dim lZei As Long, lSpa As Long, uZ As Long, dummy As Long
Dim i As Long, b As Long, a As Long
Dim GesBer As Range, zelle As Range
Dim suchWort As String, suchWortZus As String
uZ = 1 ' Zeile in der die Überschriften stehen
On Error GoTo Errorhandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ActiveWorkbook.Sheets("Tabelle1") ' Gesamtübersichtstabelle
lZei = .Range("A" & .Rows.Count).End(xlUp).Row
lSpa = .Cells(uZ, .Columns.Count).End(xlToLeft).Column
Set GesBer = .Range(.Cells(9, 3), .Cells(lZei, lSpa))
GesBer.ClearContents
ReDim ProBlaNum(-1 + Application.WorksheetFunction.CountA(.Range(.Cells(uZ, 1), Cells(uZ, lSpa))))
ReDim ProNam(-1 + Application.WorksheetFunction.CountA(.Range(.Cells(uZ, 1), Cells(uZ, lSpa))))
'Blätter mit entsprechender Komponente bestimmen
a = 0
For i = 2 To lSpa
If .Cells(uZ, i) <> "" Then
b = 2
fehlt = True
For b = 2 To ActiveWorkbook.Sheets.Count
suchWort = Application.WorksheetFunction.Trim(.Cells(uZ, i).Value)
suchWort = Application.WorksheetFunction.Substitute(suchWort, Chr(10), "") ' Zeilenümbrüche entfernen
If Not IsError(Application.Match("*" & suchWort & "*", ActiveWorkbook.Sheets(b).Range("A:A"), 0)) Then
'Blatt mit Gerät gefunden
ProBlaNum(a) = b
ProNam(a) = suchWort
a = a + 1
fehlt = False
Exit For 'b
End If
Next b
If fehlt Then
dummy = MsgBox(suchWort & " wurde in keiner Tabelle gefunden, trotzdem fortfahren?", 35, "Komponente nicht gefunden!")
If dummy = 6 Then 'ja-> fortfahren
ProBlaNum(a) = 0
ProNam(a) = suchWort
a = a + 1
Else 'nein oder abbrechen -> Beenden
MsgBox "Die Auflistung wurde abgebrochen"
GoTo Fin
End If
End If
Else
End If
Next i
'auflisten
For Each zelle In GesBer
If .Cells(uZ, zelle.Column) <> "" Then
suchWort = Application.WorksheetFunction.Trim(.Cells(uZ, zelle.Column).Value)
suchWort = Application.WorksheetFunction.Substitute(suchWort, Chr(10), "") ' Zeilenümbrüche entfernen
If ProBlaNum(Application.Match(suchWort, ProNam, 0) - 1) <> 0 _
And .Range("B" & zelle.Row).Value <> "" Then
suchWortZus = Application.WorksheetFunction.Trim(.Range("B" & zelle.Row).Value & " " & suchWort)
suchWortZus = Application.WorksheetFunction.Substitute(suchWortZus, Chr(10), "") ' Zeilenümbrüche entfernen
With ActiveWorkbook.Sheets(ProBlaNum(Application.Match(suchWort, ProNam, 0) - 1))
If Not IsError(Application.Match(suchWortZus, .Range("A:A"), 0)) Then
zelle = .Range("B" & Application.Match(suchWortZus, .Range("A:A"), 0)).Value
End If
End With
End If
End If
Next zelle
End With
MsgBox "Auflistung beendet"
Fin:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
Errorhandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Ein Fehler ist aufgetreten"
End Sub
Kann es vorkommen das eine Firma-Komponente-Kombination zwar in einer der Einzeltabellen aber nicht in der Gesamttabelle vorkommt? Diese würden momentan nicht getroffen werden.
Wozu VBA? Das geht mit einer einfachen Formel (Mache aus den Überschriften bitte GPU und CPU sonst wird es etwas komplizierter):
B3: =INDEX(Tabelle2!$B:$B;VERGLEICH($A3&" "&B$2;Tabelle2!$A:$A;0))
Die Formel nach rechts kopieren und anschließend die ganze Zeile nach unten.
Hilft Dir das?
In meiner Beispieltabelle, welche ich hier zur Schau gestellt habe funktioniert das wunderbar ! In der eigentlichen Tabelle leider nicht - da die Verteilung der Zellen etc. natürlich abweichend ist.
Ich würde die "Original" Tabelle 1zu1 mit Beispieldaten nachbauen, sodass du mir die Formel passend dazu erstellen könntest, worüber ich sehr dankbar wäre. (Bild: https://ibb.co/McTZ6Q9 )
Andererseits würde ich die Formel auch gerne Nachvollziehen können, wenn du on-top diese noch erklären könntest, wäre das wirklich das Exzellent !
Vielen Dank vorab !!
Ich schlage vor du ordnest dein Datum um,
Dann hilft PIVOT und keine Formel mehr nötig.
Leicht zu warten und zu erweitern und auch spontan andere Analysen möglich.
