Zellenbezeichnungen per Makro als neues Tab

Hallo zusammen,
ich weiß, dass dieses Thema bereits einige Male behandelt wurde, leider erhalte ich bei der Ausführung vorgeschlagener Makros eine Fehlermeldung. Als VBA Laie kann ich mir darauf aber leider keinen Reim machen.
Folgendes möchte ich erreichen:
Ich habe eine Tabelle mit verschiedenen Spalten. Die Spalte A beinhaltet als Überschrift die Bezeichnung Brand und als Inhalt 218 Firmennamen untereinander.
Bspw:
A
Adobe
Airbus
Allianz
Apple
Zu diesen Namen aus der Tabelle (insgesamt also 218) soll jeweils ein neues Tabellenblatt erstellt werden, das als Tab-Bezeichnung den Namen der Firma/Brand aus der jeweiligen Zelle trägt.
Zusätzlich sollen aus der jeweiligen Zeile der Firma bestimmte Informationen in das neue Tabellenblatt übernommen werden.
In meinem Fall handelt es sich im Beispiel dann um die folgenden Spalten mit den folgenden Spaltenüberschriften
und einem Beispiel, welche Informationen in meiner Tabelle stehen:
A: Brand - Apple
M: Continent - NORTH AMERICA
N: Country - US
O: City - Cupertino
P: Employees - 110.000
Q: Webseite - www.apple.com
Diese sollen dann im Prinzip so in der jeweils neuen Tabelle pro Firma landen, dass die Spaltenüberschriften aus A, M, N, O, P, Q in den Zellen A1, A2, A3, A4, A5, A6 landen und die Informationen zu der jeweiligen Firma/Brand in Spalte B:
Zelle A1: Brand B1: Apple
Zelle A2: Continent B2: NORTH AMERICA
Zelle A3: Country: B3: US
Zelle A4: City B4: Cupertino
Zelle A5: Employees B5: 110.000
Zelle A6: Webseite B6: www.apple.com
Kann mich dabei jemand unterstützen?
Das wäre toll.
Viele Grüße
Thomas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub x() Dim Zelle, Bereich As Range Dim i As Integer Dim nWS As Worksheet Dim Bool As Boolean Set Bereich = Range("A1:A" & Range("A65536").End(xlUp).Row) For Each Zelle In Bereich For i = 2 To Worksheets.Count If Worksheets(i).Name = Zelle.Value Then Bool = True Exit For Else Bool = False End If Next i If Bool = False Then Set nWS = Worksheets.Add(after:=Worksheets(Worksheets.Count)) nWS.Name = Zelle.Value End If Next Zelle End Sub Wenn ich nach dem Laufzeitfehler 1004 auf debuggen gehe, markiert er mit die viertletzte Zeile _ nWS.Name = Zelle.Value in gelb. Der Fehler lautet Fehler der Methode Name des Objekts _Worksheet. Die Datei mit dem fehlerhaften Makro und der Urspungstabelle liegt hier: https://www.herber.de/bbs/user/106534.xlsx _ a> Ich arbeite mit Office 2011 auf einem MacBook, kann mir aber nicht vorstellen, dass es daran _ liegt. Viele Grüße Thomas

Hallo,
du hast verbotene Zeichen (/:) in den Namen. die habe ich durch _ ersetzt. Und manche sind länger als 31 Zeichen die musste ich kürzen.
Teste mal:

Option Explicit

Public Sub Distribute()

    Dim objCell As Range
    Dim lngIndex As Long
    Dim objWorksheet As Worksheet
    Dim strSheetName As String
    Dim blnFound As Boolean

    Application.ScreenUpdating = False

    For Each objCell In Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))

        strSheetName = Left$(Replace(Replace(objCell.Value, "/", "_"), ":", "_"), 31)

        blnFound = False

        For lngIndex = 2 To Worksheets.Count
            If Worksheets(lngIndex).Name = strSheetName Then
                blnFound = True
                Exit For
            End If
        Next lngIndex

        If Not blnFound Then
            Set objWorksheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            With objWorksheet
                .Name = strSheetName
                .Cells(1, 1).Value = "Brand"
                .Cells(1, 2).Value = objCell.Value
                .Cells(2, 1).Value = "Continent"
                .Cells(2, 2).Value = objCell.Offset(0, 12).Value
                .Cells(3, 1).Value = "Country"
                .Cells(3, 2).Value = objCell.Offset(0, 13).Value
                .Cells(4, 1).Value = "City"
                .Cells(4, 2).Value = objCell.Offset(0, 14).Value
                .Cells(5, 1).Value = "Employees"
                .Cells(5, 2).Value = objCell.Offset(0, 15).Value
                .Cells(6, 1).Value = "Webseite"
                .Cells(6, 2).Value = objCell.Offset(0, 16).Value
                .Columns(2).AutoFit
            End With
            Set objWorksheet = Nothing
        End If
    Next objCell

    Worksheets(1).Select

    Application.ScreenUpdating = True

End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Zellenbezeichnungen per Makro als neues Tab

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread