Anzeige

VBA
Programmierer
gesucht?
 
Anzeige
VBA Programmierer gesucht?
 

VBA Codeschnipselsammlung

Konsolidierung einer Tabellenspalte bei sonst gleichen Spalteninhalten...

Folgende Situation: Sie haben eine Gerätetabelle und möchten gerne alle Seriennummern eines Gerätetyps mit einem Komma getrennt in der Spalte Seriennummern haben.

Zur Verdeutlichung einmal die Tabelle1 (Ausgangslage) und die gewünschte Auswertungstabelle (Ergebnis).

  A B C D E
 1  Name Hersteller Typ Preis Seriennummern
 2  Maus Hersteller A 1 50 Euro A223B442
 3  Maus Hersteller A 1 50 Euro A223B442
 4  Monitor Hersteller B 1 199 Euro X333J598
 5  Gehäuse Hersteller C 2 99 Euro F456Z662
 6  Gehäuse Hersteller C 2 99 Euro F456Z667
 7  Tastatur Hersteller A 1 29 Euro T661H532
 8  Tastatur Hersteller A 1 29 Euro T662H522

Und das Ergebnis nach dem Konsolidierungsmakro sollte so aussehen:

  A B C D E
 1  Name Hersteller Typ Preis Seriennummern
 2  Maus Hersteller A 1 50 Euro A223B442, A223B442
 3  Monitor Hersteller B 1 199 Euro X333J598
 4  Gehäuse Hersteller C 2 99 Euro F456Z662, F456Z667
 5  Tastatur Hersteller A 1 29 Euro T661H532, T662H522


Für diese Konsolidierung finden Sie folgend ein Beispielmakro:

Option Explicit
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_konsolidierung1.php
' ************************************************************************************************


Sub MWTabellenKonsolidierung()
   Dim lQuellZeile As Long
   Dim lZielZeile As Long
   Dim lSpalte As Long
   Dim lSuchZeile As Long
   Dim oQuelle As Object
   Dim oZiel As Object
   Dim bFlag As Boolean
   Dim sVergleichQuelle As String
   Dim sVergleichZiel As String
    
     Set oQuelle = Sheets("Tabelle1")
    
     Set oZiel = Sheets.Add
     lZielZeile = 2
    
     Application.ScreenUpdating = False 'Flackern ausschalten
    
     'überschriften eintragen
     For lSpalte = 1 To 5
         oZiel.Cells(1, lSpalte).Value = oQuelle.Cells(1, lSpalte).Value
     Next lSpalte
    
     'Konsolidierung
     For lQuellZeile = 2 To oQuelle.UsedRange.Rows.Count + oQuelle.UsedRange.Row - 1
    
         bFlag = False
        
         'Prüfen ob Zeile schon vorhanden!
         For lSuchZeile = 2 To oZiel.UsedRange.Rows.Count + oZiel.UsedRange.Row - 1
             sVergleichQuelle = ""
             sVergleichZiel = ""
             For lSpalte = 1 To 4
                 sVergleichQuelle = sVergleichQuelle & CStr(oQuelle.Cells(lQuellZeile, lSpalte).Text)
                 sVergleichZiel = sVergleichZiel & CStr(oZiel.Cells(lSuchZeile, lSpalte).Text)
             Next lSpalte
             If LCase(Trim(CStr(sVergleichQuelle))) = LCase(Trim(CStr(sVergleichZiel))) Then
                 bFlag = True
                 Exit For
             End If
         Next lSuchZeile
        
         'Prüfergebnis entscheidet ob bereits vorhanden oder eine neue Zeile angelegt werden muss
         If bFlag = True Then 'Bereits vorhanden also nur anhängen
             oZiel.Cells(lSuchZeile, 5).Value = oZiel.Cells(lSuchZeile, 5).Text & _
                 ", " & oQuelle.Cells(lQuellZeile, 5).Text
         Else 'Zeile als neu unten anhängen
             For lSpalte = 1 To 5
                 'Inhalt übertragen ein führendes ' erzwingt die Textübernahme!!!
                 oZiel.Cells(lZielZeile, lSpalte).Value = _
                     CStr("'" & oQuelle.Cells(lQuellZeile, lSpalte).Value)
             Next lSpalte
             lZielZeile = lZielZeile + 1
         End If
     Next lQuellZeile
    
     'Aufräumen
     Application.ScreenUpdating = True
     Set oZiel = Nothing
     Set oQuelle = Nothing
End Sub


Autor: Marc Wershoven (2013)

Anzeige

VBA Programmierer gesucht?
http://www.WershovenOnline.de

Anzeige

Der Quick E-Mail Support von WershovenOnline®

Schnelle Hilfe bei Fragen rund um Microsoft® Office und VBA Makros

Der Quick E-Mail Support von WershovenOnline® Sie haben beispielsweise eine Frage zu einer Ihrer eigenen Makroprogrammierungen in VBA? Oder Sie suchen Unterstützung und Informationen über eine bestimmte Microsoft® Excel® Formel? Bei nahezu allen Fragen und Problemen rund um Microsoft® Office und VBA Makros steht Ihnen unser individueller Quick E-Mail Support zur Verfügung. Einfach, schnell und unkompliziert Ihre Frage in einer E-Mail formulieren, mit oder ohne Screenshots oder einer Beispieldatei absenden und kurze Zeit später haben Sie eine vollständige Lösung inkl. ausführlicher Erklärung vom Profi in Ihrem Postfach! Zusätzlich besteht die Option, dass wir uns mittels Fernwartung (selbstverständlich nach Ihrem Einvertändnis) direkt "live" mit Ihnen zusammen an Ihrem Bildschirm gemeinsam Fragen und Problemstellungen anschauen und lösen können!

Weitere Informationen zu diesem kostenpflichtigen Angebot finden Sie auf der Anbieterseite von WershovenOnline® auf www.wershovenonline.de.

Zum Anbieter des Quick-E-Mail-Support...

Zum Seitenanfang