Excel - Makro - Gruppen erstellen und als intelligente Tabelle benennen

Question

Hallo,

ich hoffe mir kann hier geholfen werden!

Folgendes Problem habe ich, welches ich aktuell per Handarbeit erledige, ist jedoch sehr umfangreich.

Daher wollte ich mal fragen, ob man das per Makro schneller erledigen kann.

Wie auf dem folgenden Scrennshot zu sehen ist, habe ich einen Datenbereich von A11:Bxxx

Das Makro soll mir z.B. ab F10 folgendes Ausgeben

- in Zeile 10 die einzelnen Marken
- darunter alle in Spalte B vorhandenen Typen
- dann soll der Bereich (z.B. hier im Screen) F10:F13 als intelligente Tabelle formatiert werden und als VW benannt werden
- dann daneben die nächste Gruppe G10:G15 als Tabelle und Namen BMW

....

das sind ja nur Beispiele, ich sammle keine Typenbezeichnungen ;-)

Kann mir hier jemand helfen? Danke vorab für eure Mühe!

Gruß

Max

Answer 1

Hi Max,

das lässt sich mit folgendem Makro realisieren:

Sub Einzeltabellen()
    Dim objDic As Object
    Dim rngBereich As Variant
    Dim lngZaehler As Long
    Dim intSpalte As Integer
    Dim blnFilter As Boolean
    Dim lngLetzte As Long
    Dim arrWerte()
    Set objDic = CreateObject("Scripting.Dictionary")
    intSpalte = 6
    With Worksheets("Tabelle1")
        rngBereich = .Range("A11", .Range("A11").End(xlDown))
        For lngZaehler = LBound(rngBereich) To UBound(rngBereich)
            objDic(rngBereich(lngZaehler, 1)) = 0
        Next
        arrWerte = objDic.keys
        If .AutoFilterMode = True Then blnFilter = True
        For lngZaehler = 0 To UBound(arrWerte())
            .Range("A11").AutoFilter field:=1, Criteria1:=arrWerte(lngZaehler)
            lngLetzte = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count
            .AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Copy .Cells(10, intSpalte)
            .Cells(10, intSpalte) = arrWerte(lngZaehler)
            .Range("A11").AutoFilter
            .ListObjects.Add(SourceType:=xlSrcRange, Source:=Range(Cells(10, intSpalte), Cells(lngLetzte + 9, intSpalte)), XlListObjectHasHeaders:=xlYes).Name = arrWerte(lngZaehler)
            intSpalte = intSpalte + 2
        Next lngZaehler
        For lngZaehler = intSpalte - 3 To 6 Step -2
            .Columns(lngZaehler).Delete
        Next lngZaehler
        If blnFilter Then .Range("A11").AutoFilter
    End With
End Sub

Bis später, Karin

Answer 2

Hallo Karin,

danke für deine Antwort.

Ich verstehe zwar nur Bahnhof, aber es funktioniert.

Danke für deine Mühe, du hast mir sehr geholfen!

lg Max

Answer 3

Hallo nochmals,

sorry, ich hätte noch eine Zusatzfrage.

Ich bräuchte noch eine zusätzliche Spalte, also in Spalte C steht jeweils, wie die Tabelle benannt werden soll. nicht der Inhalt aus Spalte A.

Die Spalte A soll die Überschrift sein, alles aus Spalte B jeweils unter der zugehörigen von A und die Beschriftung der Tabelle soll der Wert aus Spalte C sein.

ich hoffe das war halbwegs verständlich, sonst lade ich dann noch einen Screenshot hoch

Bitte um Hilfe!

lg Max

Answer 4

Hi Max,

du schreibst "Spalte A soll Überschrift sein" und "Beschriftung der Tabelle soll aus Spalte C sein" - Überschrift und Beschriftung ist dasselbe. Meinst du vielleicht dass der Name der Tabelle aus Spalte C genommen werden soll? Wenn dem so ist, dann sind folgende Bedingungen einzuhalten:

1. der Name darf nicht mit einer Ziffer beginnen

2. der Name darf keine Leerzeichen oder andere nicht zulässige Zeichen enthalten

3. derselbe Name darf nicht bereits für einen anderen Bereich vergeben sein

Ist wenigstens EINE der Bedingungen 1-3 nicht erfüllt, bricht der Code mit einem Laufzeitfehler ab.

4. der Name muss in mindestens einer Zelle der Spalte C für jede der Tabellen-Überschriften aus Spalte A stehen, damit der Name gefunden werden kann, der der betreffenden Tabelle zugewiesen werden soll. Sollte einer Tabelle kein Name in Spalte C zugewiesen sein, dann wird diese Tabelle nicht umbenannt sondern sie behält den Namen, der ihr vorher zugewiesen wurde. Ein Laufzeitfehler tritt in diesem Fall nicht ein.

        Dim strStart As String
        For lngZaehler = 0 To UBound(arrWerte())
            Set rngBereich = Columns(1).Find(arrWerte(lngZaehler), lookat:=xlWhole)
            If Not rngBereich Is Nothing Then
                strStart = rngBereich.Address
                Do
                    If rngBereich.Offset(0, 2) <> "" Then
                        ActiveSheet.ListObjects(arrWerte(lngZaehler)).Name = rngBereich.Offset(0, 2).Value
                        Exit Do
                    Else
                        Set rngBereich = Columns(1).FindNext(rngBereich)
                    End If
                Loop While rngBereich.Address <> strStart
            End If
        Next lngZaehler

Bis später, Karin

 

Answer 5

Hallo Karin,

Danke, das funktioniert wunderbar!!!

Natürlich habe ich den Namen der Tabelle gemeint, ich konnte mich als unwissender nicht richtig ausdrücken!

Die ganzen Parameter die notwendig sind kann ich gewährleisten, sonst bricht das Makro sowieso ab.

Danke dir nochmals für deine profesionelle Hilfe!

Eine Frage noch zum Ende.

Wie kann man sowas grundlegend erlernen?
Welche Schritte würdest du empfehlen, das du sagst fang einmal damit und damit an....

Wäre nett wenn du einem interessierten ein paar Tipps geben kannst.

DANKE

lg Max

Answer 6

Hi Max,

das ist eine schwierige Frage, die sich nicht so einfach beantworten lässt. Am günstigsten ist natürlich wenn du einen Programmierkurs besuchst, in dem du die Grundlagen der Programmierung kennenlernst.

Auf jeden Fall aber kannst du den Makrorekorder von Excel verwenden - durch ihn lernst du alle (oder zumindest die meisten) Befehle kennen und was sie machen. Google ist dabei natürlich ebenfalls eine unentbehrlich Hilfe, um mehr über die einzelnen Befehle und ihre Wirkung zu erfahren.

Und auf jeden Fall hilft, wenn du versuchst einzelne Beispiele aus dem Forum oder aus anderen Internet-Quellen selbst zu lösen, denn damit festigst du deine Kenntnisse.

Und einen Rat gebe ich dir noch gratis obendrauf : wenn mal etwas nicht so funktioniert wie du es möchtest - nicht aufgeben, irgendwann funktioniert dann alles.

Bis später, Karin