Office: Excelliste auf mehrere Blätter verteilen

HR85 · 20. Mai 2014

Hi zusammen,

ich ziehe mir jeden Monat eine Liste aus unserer Datenbank. Die Liste hat immer 4 Spalten aber unterschiedliche viele Zeilen.

Hier ein Auszug der Liste. Im Original ist sie bedeutend länger.

http://www.herber.de/bbs/user/90783.xlsx

In Spalte D steht immer die store_id (insg. ca 90 werden aber zukünftig mehr). Excel soll jetzt für jede store_id ein eigenes Tabellenblatt anlegen und die Liste genau wie in der ursprungsform (also mit den gleichen Spalten) aber jeweils nur die Zeilen mit der entsprechenden store_id auf diese Tabellenblätter verteilen. Idealerweise in aufsteigender Reihenfolge, 1-2-3 usw. Ist aber nicht sooo wichtig falls das zu kompliziert ist.

Anschließend soll für jedes der Tabellenblätter folgender Code ausgeführt werden, der jedes Tabellenblatt formatiert.

Sub GAForm()
Rows(1).ClearContents

With Cells(3, 2).CurrentRegion
With .Offset(-1, 0).Resize(.Rows.Count + 2)
.Cells(1, 1).Value = 1
.Cells(1, 1).Copy
.SpecialCells(xlCellTypeConstants, 2).PasteSpecial xlPasteValues, operation:=xlMultiply
.Rows(1).Value = Array("Datum", "Code", "Wert")
.Columns(1).NumberFormat = "DD.MM.YYYY hh:mm"
.Cells(.Rows.Count, 1).Value = "Summe"
.Cells(.Rows.Count, 3).FormulaR1C1 = "=Sum(R[-" & .Rows.Count - 2 & "]C:R[-1]C)"
.BorderAround Weight:=xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Rows(1).Font.Bold = True
.Rows(.Rows.Count).Font.Bold = True
.Cut Destination:=Cells(5, 1)
Columns("A:A").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Columns("B:B").EntireColumn.AutoFit
Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "#,##0.00 $"
Rows("4:4").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
End With

End Sub

Kann mir da jemand helfen? Wäre genial!

BG
Henrik

:)

chris-kaiser · 22. Mai 2014

Hi,

vgl. dazu http://www.ms-office-forum.de/forum/...d.php?t=309704
ist das selbe Prinzip

Mc Santa · 22. Mai 2014

Maaaan, ich hab mal wieder zu lange getestet ...

Naja hier ist mein Code:
Code:

Option Explicit

Sub export()
Dim id As Long
Dim ber As Range, r As Range
Dim wks As Worksheet

With Sheets("Tabelle1")
Set ber = .Range(.Range("D1").End(xlDown), .Range("D1"))

For Each r In ber

If Not sheetExists(CStr(r.Value)) Then
Set wks = ThisWorkbook.Worksheets.Add
wks.Name = r.Value
Else
Set wks = ThisWorkbook.Worksheets(CStr(r.Value))
End If

wks.Cells.Clear

wks.Cells(1, 1) = ber.Cells(1, 1)
wks.Cells(2, 1) = r.Value

.Range(.Range("A1").End(xlDown), .Range("A1").End(xlToRight)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wks.Range(wks.Cells(1, 1), wks.Cells(2, 1)), _
CopyToRange:=wks.Cells(3, 1), Unique:=False
wks.Range("A1:A2").EntireRow.Delete
GAForm wks
Next r
End With
End Sub

Sub GAForm(wks As Worksheet)

With wks
.Rows(1).ClearContents

With .Cells(3, 2).CurrentRegion
With .Offset(-1, 0).Resize(.Rows.Count + 2)
.Cells(1, 1).Value = 1
.Cells(1, 1).Copy
On Error Resume Next
.SpecialCells(xlCellTypeConstants, 2).PasteSpecial xlPasteValues, operation:=xlMultiply
On Error GoTo 0
.Rows(1).Value = Array("Datum", "Code", "Wert", "Store ID")
.Columns(1).NumberFormat = "DD.MM.YYYY hh:mm"
.Cells(.Rows.Count, 1).Value = "Summe"
.Cells(.Rows.Count, 3).FormulaR1C1 = "=Sum(R[-" & .Rows.Count - 2 & "]C:R[-1]C)"
.BorderAround Weight:=xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Rows(1).Font.Bold = True
.Rows(.Rows.Count).Font.Bold = True
.Cut Destination:=Cells(6, 1)
wks.Columns("A:A").EntireColumn.AutoFit
wks.Activate
ActiveWindow.DisplayGridlines = False
wks.Columns("B:B").EntireColumn.AutoFit
wks.Range(wks.Range("C7"), wks.Range("C7").End(xlDown)).NumberFormat = "#,##0.00 $"
End With
End With
End With

End Sub

Function sheetExists(strNam As String) As Boolean
On Error Resume Next
sheetExists = Sheets(strNam).Index > 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Freue mich über Feedback *Smilie
VG

@chris: Gefällt mir sehr die Pivot-Lösung!

chris-kaiser · 22. Mai 2014

Hi,

aber dafür besser angepasst ^^

wenn man meinen Code damit vergleicht.

Code:

.UsedRange.Borders.LineStyle = xlThin
.UsedRange.Columns.AutoFit
'oder was immer du da noch formatieren willst
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

*Smilie

HR85 · 23. Mai 2014

Schonmal besten dank für eure Antworten *Smilie

@McSanta:

Dein Skript verteilt schonmal die Daten auf unterschiedliche Blätter. Leider werden einige Blätter mit den gleichen Daten gefüllt. In der Blattbezeichnung steht zwar dann immer eine andere store_id aber die Datensätze in den einzelnen Blättern sind häufig gleich. Hast du da noch eine Idee?

Mc Santa · 23. Mai 2014

Hallo!

Ich habe eine Referenz in deiner Formatierung übersehen!! Mist *biggrin.gif*
Hab beim Anpassen gleich noch ein paar Änderungen vorgenommen, sollte jetzt schneller sein *Smilie

Bitte den gesamten Code ersetzen
Code:

Option Explicit

Sub export()
Dim id As Long
Dim ber As Range, r As Range
Dim wks As Worksheet

For Each wks In Worksheets
If wks.Name "Tabelle1" Then
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
End If
Next wks

With Sheets("Tabelle1")
Set ber = .Range(.Range("D1").End(xlDown), .Range("D1"))

For Each r In ber

If Not sheetExists(CStr(r.Value)) Then
Set wks = ThisWorkbook.Worksheets.Add
wks.Name = r.Value
wks.Cells.Clear

wks.Cells(1, 1) = ber.Cells(1, 1)
wks.Cells(2, 1) = r.Value

.Range(.Range("A1").End(xlDown), .Range("A1").End(xlToRight)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wks.Range(wks.Cells(1, 1), wks.Cells(2, 1)), _
CopyToRange:=wks.Cells(3, 1), Unique:=False
wks.Range("A1:A2").EntireRow.Delete
GAForm wks
End If
Next r
End With
Application.DisplayAlerts = False
Worksheets(ber.Cells(1, 1).Value).Delete
Application.DisplayAlerts = True

End Sub

Sub GAForm(wks As Worksheet)

With wks
.Rows(1).ClearContents

With .Cells(3, 2).CurrentRegion
With .Offset(-1, 0).Resize(.Rows.Count + 2)
.Cells(1, 1).Value = 1
.Cells(1, 1).Copy
On Error Resume Next
.SpecialCells(xlCellTypeConstants, 2).PasteSpecial xlPasteValues, operation:=xlMultiply
On Error GoTo 0
.Rows(1).Value = Array("Datum", "Code", "Wert", "Store ID")
.Columns(1).NumberFormat = "DD.MM.YYYY hh:mm"
.Cells(.Rows.Count, 1).Value = "Summe"
.Cells(.Rows.Count, 3).FormulaR1C1 = "=Sum(R[-" & .Rows.Count - 2 & "]C:R[-1]C)"
.BorderAround Weight:=xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Rows(1).Font.Bold = True
.Rows(.Rows.Count).Font.Bold = True
.Cut Destination:=wks.Cells(6, 1)
wks.Columns("A:A").EntireColumn.AutoFit
wks.Activate
ActiveWindow.DisplayGridlines = False
wks.Columns("B:B").EntireColumn.AutoFit
wks.Range(wks.Range("C7"), wks.Range("C7").End(xlDown)).NumberFormat = "#,##0.00 $"
End With
End With
End With

End Sub

Function sheetExists(strNam As String) As Boolean
On Error Resume Next
sheetExists = Sheets(strNam).Index > 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Fragen und Feedback immer gern gesehen *Smilie
VG

HR85 · 23. Mai 2014

geiler scheiß! funktioniert super und schnell...

wie lange braucht man um das zu lernen? bin blutiger Anfänger was vba angeht, haste irgendwelche tips?

Mc Santa · 23. Mai 2014

Hallo!

Toll, dass es geht *Smilie

Wenn du schon grundlegende Programmierkenntnisse hast, kommt man mit VBA schnell zurecht.

Wenn du bestimmte Befehle nicht weißt, zb willst du eine Zelle färben, dann Zeichne das ganze mit dem Makro-Rekorder auf und kopiere den Befehl. Oder du suchst bei google. Beim obigen Problem war die eigentliche Schwierigkeit, dass du auf die Idee des Filtern über Spezialfilter oder Pivot-Tabelle kommst. Das zeichne ich dann einmal auf und passe es anschließend an.

Versuche dich daran Makro-Rekorder Code anzupassen und komme bei Problemen hier ins Forum!
Zum Makro-Rekorder sei noch gesagt: er zeichnet viele Selekt und Activate Befehle auf, die man nicht braucht. Die musst du hinterher alle anpassen. folgendes habe ich dazu gefunden: http:// w w w .online-excel.de/excel/singsel_vba.php?f=78

Viel Erfolg!

HR85 · 23. Mai 2014

ok, top danke!

HobbitHB · 29. November 2018

Hallo, ich nutze einfach mal diesen Post und klinke mich mit meinem identischen Problem ein.

Ich befürchte das es eigentlich einfach sein sollte - da die Lösung ja scheinbar oben steht - für mich als total Noob was das angeht (ich wusste bis vor 5 Minuten nicht mal, das man in Excel programmieren kann)...

Ich erstelle derzeit anhand einer Excel Liste Preisschilder in Word mit Serienbrief funktion. Die Schilder gibt es in A4, A5, A6 und A7. Soweit so gut.
Natürlich habe ich für jeden Werbeauftritt eine neue Produktliste. Ich pflege also alle Produkte in eine Main-Liste mit der Info welches Produkt welche Preisschildgröße bekommt. Nun möchte ich anhand dieser Größe die Main-Tabelle aufsplitten in Blätter A4, A5, A6 und A7.

Da weiß ich nur nicht wie ich es machen muss, geschweige denn, wo ich irgendwelche codes einfügen muss.... (SORRY). Ziel ist es, dass ich nur die Liste komplett ändern muss...

Vielen Dank im Vorraus

Liebe Grüße

Kiki

Drogist · 30. November 2018

Moin, erst einmal ein Hinweis: Ein neuer Thread wäre gewiss besser gewesen...
Ich denke, dass ich das mit Power Query lösen würde. Ohne eine einzige Zeile Programm-Code.

Office: Excelliste auf mehrere Blätter verteilen

Excelliste auf mehrere Blätter verteilen

Excelliste auf mehrere Blätter verteilen

Excelliste auf mehrere Blätter verteilen

Excelliste auf mehrere Blätter verteilen

Excelliste auf mehrere Blätter verteilen - Similar Threads - Excelliste Blätter verteilen

Zwei Excellisten kompinieren

Excelliste von senkrecht nach waagrecht sortieren

Excelliste duch "anderen Benutzer" gesperrt

Ordner via Excelliste erstellen und Unterordner hineinkopieren

Suchfunktion in anderer Excelliste mit Ausgabe

Excelliste mit Bild Anhang

Datenübernahme in neue Excelliste