Live-Forum - Die aktuellen Beiträge
Datum
Titel
20.04.2024 00:49:19
Excel Sheet in einen Excel Kalender einfügen
20.04.2024 00:08:11
In Ordner nur das Speichern von Dateien erlauben
19.04.2024 21:26:15
mehrfache Texte finden
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1864to1868
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1864to1868
1864to1868
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Aus Gesamtdatei>Tabellenblätter erzeugen

Aus Gesamtdatei>Tabellenblätter erzeugen
21.01.2022 17:01:07
Alex
Hallo und einen wunderschönen Guten Abend,
ich habe mal wieder eine kleine Herausforderung, bei der ich eure Unterstützung benötige.
Basis bildet eine Excel Datei: (Sheet) Enthält alle Lieferanten und dazugehörigen Spalten / Informationen
Wir wollen gerne daraus Tabellenblätter erzeugen die dann die jeweiligen Lieferanten und dazugehörigen Spalten / Informationen enthält.
Ich habe eine Demo-Datei hochgeladen.
https://www.herber.de/bbs/user/150575.xlsx
Freue mich auf Euren Support
Alex

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Aus Gesamtdatei>Tabellenblätter erzeugen
21.01.2022 18:04:32
Yal
Hallo Alex,
Finger-Übung.

Const HauptBlatt = "Sheet"
Sub Dispatch()
Dim qW As Worksheet 'Quelle
Dim zW As Worksheet 'Ziel
Dim Z As Range      'Zelle
Const Deb = 5 'Spalte E
Set qW = Worksheets(HauptBlatt)
For Each Z In qW.Range(qW.Range("A2"), qW.Cells(qW.Rows.Count, "A").End(xlUp))
Set Z = Z.EntireRow
Set zW = WS_Selekt(Z.Cells(1, Deb).Value)
Z.Copy zW.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
End Sub
Private Function WS_Selekt(BlattName As String) As Worksheet
Dim W As Worksheet
On Error Resume Next
Set W = Worksheets(BlattName)
If W Is Nothing Then
Set W = Worksheets.Add(after:=Worksheets(Worksheets.Count))
W.Name = BlattName
Worksheets(HauptBlatt).Range("1:1").Copy W.Range("A1")
End If
Set WS_Selekt = W
End Function
VG
Yal
Anzeige
Ach So...
21.01.2022 18:06:45
Yal
... Wenn Arbeitsblätter mit den Namen der Debitoren bereits existieren, werden darin die Einträge aus der Hauptblatt am Ende der vorhandenen hinzugefügt.
Aber das hättest Du schnell bemerkt.
VG
Yal
AW: Ach So...
21.01.2022 18:33:09
Alex
Hallo Yal, die Blätter existieren nicht. Diese hatte ich als "Beispiel" eingetragen.
Ich habe nur das "Sheet1" Tabellenblatt.
AW: Ach So...
21.01.2022 18:35:39
Alex
Vielen Dank Yal funktioniert tadellos!
AW: Ach So...
21.01.2022 18:38:34
Alex
Und Yal, noch eine Frage, wenn ich aus dem gesamten Set nur definierte Spalten übertragen möchte, wie selektiere ich diese?
z.B. Spalte 5,6,8,12,18,22 etc.
AW: Ach So...
21.01.2022 23:44:38
Yal
Hallo Alex,
Bin gerade am Handy, daher wird es bestimmt Fehler geben :-)

Const HauptBlatt = "Sheet"
Sub Dispatch()
Dim qW As Worksheet 'Quelle
Dim zW As Worksheet 'Ziel
Dim Z As Range      'Zelle
Const Deb = 5 'Spalte E
Set qW = Worksheets(HauptBlatt)
For Each Z In qW.Range(qW.Range("A2"), qW.Cells(qW.Rows.Count, "A").End(xlUp))
Set zW = WS_Selekt(Z.Offset(0, Deb - 1).Value)
Kopieren qW, zW, Z.Row
Next
End Sub
Private Function WS_Selekt(BlattName As String) As Worksheet
Dim W As Worksheet
On Error Resume Next
Set W = Worksheets(BlattName)
If W Is Nothing Then
Set W = Worksheets.Add(after:=Worksheets(Worksheets.Count))
W.Name = BlattName
Kopieren Worksheets(BlattName), W, 1
End If
Set WS_Selekt = W
End Function
Private Sub Kopieren (qW As Worksheet, zW As Worksheet, ByVal Zeile As Long)
Dim S
Dim Z
Dim sp
sp = Array(5,6,8,12,18,22)
Z = zW.Cells(zW.Rows.Count, 1).End(xlUp).Row +1
If Zeile = 1 Then Z = 1 'Ausnahme Überschrift-Zeile
For S = 0 To UBound(sp)
qW.Cells(Zeile, sp (S)).Copy zW.Cells(Z, S + 1)
Next
End Sub
VG
Yal
Anzeige
AW: Ach So...
22.01.2022 09:52:37
Alex
Funktioniert Yal, lediglich die fixe Überschrift ist weg. Heisst Zeile 1 ist
AW: Ach So...
22.01.2022 09:52:59
Alex
Funktioniert Yal, lediglich die fixe Überschrift ist weg. Heisst Zeile 1 ist leer
AW: Ach So...
22.01.2022 12:55:24
Yal
Hallo Alex,
Ja, sehe ich gerade. In der WS_Selekt habe ich die 2 Worksheets beim Aufruf von Kopieren vertauscht.
Kopieren W, Worksheets(BlattName), 1
sollte richtig sein.
VG
Yal
AW: Ach So...
22.01.2022 18:14:49
Alex
Habe es jetzt so übernommen:

Const HauptBlatt = "Sheet1"
Sub Dispatch()
Dim qW As Worksheet 'Quelle
Dim zW As Worksheet 'Ziel
Dim Z As Range      'Zelle
Const Deb = 26 'Spalte E
Set qW = Worksheets(HauptBlatt)
For Each Z In qW.Range(qW.Range("A2"), qW.Cells(qW.Rows.Count, "A").End(xlUp))
Set zW = WS_Selekt(Z.Offset(0, Deb - 1).Value)
Kopieren qW, zW, Z.Row
Next
End Sub
Private Function WS_Selekt(BlattName As String) As Worksheet
Dim W As Worksheet
On Error Resume Next
Set W = Worksheets(BlattName)
If W Is Nothing Then
Set W = Worksheets.Add(after:=Worksheets(Worksheets.Count))
W.Name = BlattName
Kopieren W, Worksheets(BlattName), 1
End If
Set WS_Selekt = W
End Function
Private Sub Kopieren(qW As Worksheet, zW As Worksheet, ByVal Zeile As Long)
Dim S
Dim Z
Dim sp
sp = Array(5, 6, 8, 12, 18, 22)
Z = zW.Cells(zW.Rows.Count, 1).End(xlUp).Row + 1
If Zeile = 1 Then Z = 1 'Ausnahme Überschrift-Zeile
For S = 0 To UBound(sp)
qW.Cells(Zeile, sp(S)).Copy zW.Cells(Z, S + 1)
Next
End Sub
funktioniert, jedoch weiter ohne feste Spaltenüberschrift aus Bereich A1:xx
Anzeige
AW: Ach So...
22.01.2022 19:45:46
Yal
Hallo Alex,
doppelte Fehler: Kopieren erwatert QuellWorksheet, ZielWorksheet, QuellZeile
Daher muss es in WS_Select
Kopieren Worksheets(HauptBlatt), W, 1
lauten.
Diese neue Version ist wesentlich langsamer, da die Zelle inzel kopiert werden.
Alternativ könnte man alles kopieren und anschliessend die unnötige Zeilen löschen. Aber ich gehe davon aus, dass es hier eine einmalige Verarbeitung und die Performance spieltdaher keine Rolle.
VG
Yal
AW: Ach So...
23.01.2022 00:33:05
Alex
Hallo Yal, funktioniert tadellos. Besten Dank für Deine tolle Unterstützung. Super genial.

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige