Werte von einem Tabellenblatt auf mehrere Tabellenblätter verteilen. Einmal mit Zahlen, dann mit Texten und schließlich werden die Tabellenblätter erstellt.
Distribute values from one worksheet to several worksheets. Once with numbers, then with texts and finally the spreadsheets are created.
Hier noch eine Beispieldatei / Here's a sample file:
Werte verteilen - drei Beispiele...[ZIP 42 KB]
Code gehört in ein Modul / Code belongs in a module:
Code gehört in ein Modul / Code belongs in a module:
Code gehört in ein Modul / Code belongs in a module:
Distribute values from one worksheet to several worksheets. Once with numbers, then with texts and finally the spreadsheets are created.
Hier noch eine Beispieldatei / Here's a sample file:
Werte verteilen - drei Beispiele...[ZIP 42 KB]
Code gehört in ein Modul / Code belongs in a module:
OptionExplicit
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 26.05.2019
' Purpose : Werte verteilen - Formel in Tabellenblätter schreiben
' Note : Funktioniert erst ab Excel 2010
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimlngCalcAsLong
DimlngTMPAsLong
DimlngRowAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt
WithApplication
.ScreenUpdating=False
.EnableEvents=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithTabelle1
' Ermittelt die letzte belegte Zelle in Spalte A
lngRow=IIf(Len(.Cells(.Rows.Count,1)),.Rows.Count,_
.Cells(.Rows.Count,1).End(xlUp).Row)
EndWith
' Schleife über die drei Tabellenblätter "Registerx"
ForlngTMP=1To3
' WITH - alles bezieht such auf das jeweilige Tabellenblatt
WithThisWorkbook.Worksheets("Register"&lngTMP)
' Verschachtelte WITH-Konstruktion
With.Range(.Cells(2,1),.Cells(lngRow,7))
' Formel im ganzen Bereich eintragen
.Formula="=IFERROR(INDEX(Gesamt!A$2:A$"&lngRow&_
",AGGREGATE(15,6,ROW($A$2:$A$"&lngRow&_
")-1/(Gesamt!$C$2:$C$"&lngRow&"="&lngTMP&_
"),ROW(A1))),"""")"
' Formel durch Werte ersetzen
.Formula=.Value
EndWith
EndWith
NextlngTMP
Fin:
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=lngCalc
.DisplayAlerts=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
Code gehört in ein Modul / Code belongs in a module:
OptionExplicit
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 26.05.2019
' Purpose : Werte verteilen - Formel in Tabellenblätter schreiben
' Note : Funktioniert erst ab Excel 2010
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimvarArrAsVariant
DimlngCalcAsLong
DimlngTMPAsLong
DimlngRowAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt
WithApplication
.ScreenUpdating=False
.EnableEvents=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Array mit Werten die getrennt werden sollen befüllen
' Werte stehe im Beispiel in Spalte B
' Da es in der Formel ein String ist, müssen die
' Hochkommata entsprechend vervielfältigt werden
varArr=Array("""Test1""","""Test2""","""Test3""")
' Man kann es auch so schreiben
'varArr = Array(Chr(34) & "Test1" & Chr(34), Chr(34) & _
"Test2"&Chr(34),Chr(34)&"Test3"&Chr(34))
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithTabelle1
' Ermittelt die letzte belegte Zelle in Spalte A
lngRow=IIf(Len(.Cells(.Rows.Count,1)),.Rows.Count,_
.Cells(.Rows.Count,1).End(xlUp).Row)
EndWith
' Schleife über die drei Tabellenblätter "Registerx"
ForlngTMP=1To3
' WITH - alles bezieht such auf das jeweilige Tabellenblatt
WithThisWorkbook.Worksheets("Register"&lngTMP)
' Verschachtelte WITH-Konstruktion
With.Range(.Cells(2,1),.Cells(lngRow,7))
' Formel im ganzen Bereich eintragen Werte stehe in Spalte B
' lngTMP - 1, da es ein 0-basiertes Array ist
.Formula="=IFERROR(INDEX(Gesamt!A$2:A$"&lngRow&_
",AGGREGATE(15,6,ROW($A$2:$A$"&lngRow&_
")-1/(Gesamt!$B$2:$B$"&lngRow&"="&varArr(lngTMP-1)&_
"),ROW(A1))),"""")"
' Formel durch Werte ersetzen
.Formula=.Value
EndWith
EndWith
NextlngTMP
Fin:
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=lngCalc
.DisplayAlerts=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
Code gehört in ein Modul / Code belongs in a module:
OptionExplicit
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 26.05.2019
' Purpose : Werte verteilen - Formel in Tabellenblätter schreiben
' Note : Funktioniert erst ab Excel 2010
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimwksTMPAsWorksheet
DimvarArrAsVariant
DimlngRowZAsLong
DimlngCalcAsLong
DimlngTMPAsLong
DimlngRowAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt
WithApplication
.ScreenUpdating=False
.EnableEvents=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
ForEachwksTMPInThisWorkbook.Worksheets
' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
IfwksTMP.Index>1Then
' ... lösche es
wksTMP.Delete
EndIf
NextwksTMP
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithTabelle1
' Ermittelt die letzte belegte Zelle in Spalte A
lngRow=IIf(Len(.Cells(.Rows.Count,1)),.Rows.Count,_
.Cells(.Rows.Count,1).End(xlUp).Row)
.Range("B1:B"&lngRow).AdvancedFilter_
Action:=xlFilterCopy,_
CopyToRange:=.Range("Z1"),Unique:=True
lngRowZ=IIf(Len(.Cells(.Rows.Count,26)),.Rows.Count,_
.Cells(.Rows.Count,26).End(xlUp).Row)
' Array mit Werten die getrennt werden sollen befüllen
' Werte stehe im Beispiel in Spalte Z
varArr=Application.Transpose(Range("Z2:Z"&lngRowZ))
' Spalte Z wieder löschen
.Columns("Z").Delete
EndWith
' Schleife über die drei Tabellenblätter "Registerx"
ForlngTMP=1ToUBound(varArr)
' WITH - alles bezieht such auf DIESES Workbook
WithThisWorkbook
' Tabellenblatt hinzufügen und Name vergeben
.Worksheets.AddAfter:=_
.Worksheets(.Worksheets.Count)
.Worksheets(.Worksheets.Count).Name="Register"&lngTMP
EndWith
' WITH - alles bezieht such auf das jeweilige Tabellenblatt
WithThisWorkbook.Worksheets("Register"&lngTMP)
' Die Überschriftenzeile aus Tabelle Gesamt kopieren
Tabelle1.Rows(1).Copy.Range("A1")
' Verschachtelte WITH-Konstruktion
With.Range(.Cells(2,1),.Cells(lngRow,7))
' Formel im ganzen Bereich eintragen Werte in Spalte B
' Chr(34) weil es ein String sein muss
.Formula="=IFERROR(INDEX(Gesamt!A$2:A$"&lngRow&_
",AGGREGATE(15,6,ROW($A$2:$A$"&lngRow&_
")-1/(Gesamt!$B$2:$B$"&lngRow&"="&_
Chr(34)&varArr(lngTMP)&Chr(34)&"),ROW(A1))),"""")"
' Formel durch Werte ersetzen
.Formula=.Value
EndWith
EndWith
NextlngTMP
Fin:
' Die Applikation aufwecken
WithApplication
' Gehe zum Quelltabellenblatt nach A1
.GotoTabelle1.Range("A1"),True
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=lngCalc
.DisplayAlerts=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub