Neue ZEile - Neue Tabelle (mit Formatierung)

Moderator: ModerationP

Neue ZEile - Neue Tabelle (mit Formatierung)

Beitragvon Bosco » 14. Jul 2018, 06:30

Hallo ihr Lieben,

ich benötige eure Hilfe.

Aktuell baue ich eine Excel-Liste, die sich durch eine Selektion füllt. Daher weiß ich nie, wieviele Zeilen das Tabelle Nr.1 hat.
Daher muss ich meine Excel-Liste so konfigurieren, dass wenn sich eine neue Zeile füllt, eine neue Tabelle geöffnet wird.
In dieser neuen Tabelle, sollen die Daten automatisch in meine optisch Formatierte Liste eingefügt werden.

Wie bekomme ich dies hin? Teilt fleißig euer wissen ;D
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
Bosco
Neuling
 
Beiträge: 2
Registriert: 14. Jul 2018, 06:14

Re: Neue ZEile - Neue Tabelle (mit Formatierung)

Beitragvon Klaus-Dieter » 14. Jul 2018, 08:31

Hallo,

nach meinem Verständnis befindet sich eine Excelliste auf einem Tabellenblatt, insofern habe ich die Anfrage nicht verstanden.
Viele Grüße
Klaus-Dieter
Lösungsvorschläge sind, wenn es keinen anders lautenden Hinweis gibt, von mir getestet.
Künstliche Intelligenz ist besser als natürliche Dummheit.
Benutzeravatar
Klaus-Dieter
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 17385
Registriert: 27. Nov 2003, 23:03
Wohnort: Sassenburg

Re: Neue ZEile - Neue Tabelle (mit Formatierung)

Beitragvon Bosco » 14. Jul 2018, 12:41

Genau.
Und die Excelliste in Tabelle1 hat die Daten der Selektionen. Auf Tabelle2/3/4/5/6/7 sollen sich die Daten eintragen.
Tabelle 1:
Zeile 1= Neue Tabelle (Tabelle2)
Zeile 2= Neue Tabelle (Tabelle3)
Zeile 3= Neue Tabelle (Tabelle4)
......

Die neuen Tabellenblätter sollen sich automatisch erstellen und eine Formatierung benutzen, die bereits erstellt wurde.
Natürlich sollen die Daten der Zeilen übertragen werden.

Liebe Grüße

EDIT:
Habe ein Modul gefunden, kriege es aber nicht ans laufen.
Code: Alles auswählen
'Beide Subs in einem Standartmodul
'Aufruf erfolgt über die Sub Start

Option Explicit

Sub Start()
Dim i As Long, lngLRow As Long 'i als Zählerindex, lngLRow als letzte beschriebene Zeile
Dim wksEin As Worksheet, wksPlan As Worksheet, wksNeu As Worksheet 'Variablen für die Worksheets
Dim rngFund As Range ' wird für die Suchergebnisse in Spalte G verwendet
Dim rngErsterFund As Range ' für den Abgleich ob die Suche wieder beim ersten Ergebnis ist

'Sprungmarke zum ErrorHandler
On Error GoTo Fehler

'Ruft die Sub Löschen auf
'Diese überprüft auf doppelte Namen in den Arbeitsblättern und
'löscht diese ggf.
Call Löschen

'Schalten die Bildschirmaktualisierung aus
Application.ScreenUpdating = False

'Worksheets den Variablen zuteilen
Set wksEin = ThisWorkbook.Worksheets("EinrückDet")
Set wksPlan = ThisWorkbook.Worksheets("PlanungDet")

'letzte beschriebene Zeile in Spalte A aus Tabellenblatt("EinrückDet")
lngLRow = wksEin.Cells(wksEin.Rows.Count, 1).End(xlUp).Row
   
For i = 2 To lngLRow
    'neues Tabellenblatt erstellen und umbennen
    Set wksNeu = Sheets.Add(After:=Sheets(Sheets.Count))
    wksNeu.Name = wksEin.Range("A" & i).Text & "-" & wksEin.Range("J" & i).Text
   
    'Übernehmen der Überschrift
    wksPlan.Range("A3:E3").Copy 'Kopieren
    wksNeu.Paste Destination:=wksNeu.Range("A3")  'Einfügen
    Application.CutCopyMode = False 'Selection-Rahmen entfernen
   
    'Spalte G in Tabellenblatt("PlanungDet") nach Zelleninhalt A (aktuelle Zeile) aus Tabellenblatt("EinrückDet") durchsuchen
    'Ergebnis wird als Rangeobjekt in rngFund abgelegt
    Set rngFund = wksPlan.Range("G:G").Find(wksEin.Range("A" & i).Text, LookIn:=xlValues)
        If Not rngFund Is Nothing Then 'Überprüft ob rngFund einen Inhalt(Suchergebnis) hat
            Set rngErsterFund = rngFund 'überträgt die erste gefunden Adresse auf die Variable rngErsterFund um eine Endlosschleife zu verhindern
            Do
                'letzte beschriebene Zeile im Neuen Tabellenblatt
                lngLRow = wksNeu.Cells(wksNeu.Rows.Count, 1).End(xlUp).Row
               
                'Kopieren der Zellen A:E der gefundenen Zeile im Tabellenblatt("PlanungDet")
                wksPlan.Range("A" & rngFund.Row & ":E" & rngFund.Row).Copy
                'Einfügen in die erste leere Zeile (LngLrow+1) des neuen Tabellenblattes
                wksNeu.Paste Destination:=wksNeu.Range("A" & lngLRow + 1)
                'Entfernen des Selection-Rahmen
                Application.CutCopyMode = False
               
            'Weitersuchen
            Set rngFund = wksPlan.Range("G:G").FindNext(rngFund)
           
            'Abbruch der Schleife wenn erste Addresse gefunden wurde oder kein Suchergebnis vorhanden ist
            Loop While Not rngFund Is Nothing And rngFund.Address <> rngErsterFund.Address
        End If
Next i
'Schaltet die Bildschirmaktualisierung wieder ein
Application.ScreenUpdating = True
Exit Sub

'ErrorHandler
Fehler:
Application.ScreenUpdating = True
MsgBox Err.Description
End Sub

Private Sub Löschen()
Dim i As Long, j As Long, lngLRow As Long 'i als Zählerindex, j als Zählerindex für die Worksheets, lngLRow als letzte beschriebene Zeile

'Sprungmarke zum ErrorHandler
On Error GoTo Fehler

'Schalten die Bildschirmaktualisierung aus
Application.ScreenUpdating = False

With ThisWorkbook.Worksheets("EinrückDet")

    'letzte beschriebene Zeile in Spalte A aus Tabellenblatt("EinrückDet")
    lngLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
   
    '1. Schleife für die Zeilen im Tabellenblatt("EinrückDet")
    For i = 2 To lngLRow
        '2.Schleife für die Worksheets
        For j = ThisWorkbook.Worksheets.Count To 1 Step -1
            'Wenn Übereinstimmung dann wird das entsprechende Tabellenblatt gelöscht, somit gibt es keine Doppelte Namensvergabe
            If ThisWorkbook.Worksheets(j).Name = .Range("A" & i).Text & "-" & .Range("J" & i).Text Then
               
                Application.DisplayAlerts = False 'Schaltet die Löschnachfrage ab (Und alle anderen Benachrichtigungen)
                ThisWorkbook.Worksheets(j).Delete 'löscht das entsprechende Tabellenblatt :-P
                Application.DisplayAlerts = True 'Schaltet die Löschnachfrage wieder ein
            End If
        Next j
    Next i
End With
'Schalten die Bildschirmaktualisierung ein
Application.ScreenUpdating = True
Exit Sub

'ErrorHandler
Fehler:
Application.ScreenUpdating = True
MsgBox Err.Description
End Sub


Er wirft mir immer aus, dass der Index außerhalb des gültigen Bereichs liegt. (Neues Arbeitsblatt)
Bosco
Neuling
 
Beiträge: 2
Registriert: 14. Jul 2018, 06:14


Zurück zu Excel Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 16 Gäste