Liste Aufteilen
29.10.2021 13:13:05
tech
ich habe folgendes Problem.
Ich möchte eine große Excel Liste auf mehrere Arbeitsblätter aufteilen. Dazu habe ich ein Makro gefunden das sehr gut funktioniert. Leider habe ich in Spalte A verbundene Zellen. Wenn ich nun das Makro ausführe wird beim Aufteilen die letzte verbundene Zelle pro Teilung aufgeteilt. Schön wäre, wenn vor dem Teilen geprüft wird ob die letzte Zeile eine verbundene Zelle ist. Wenn ja erst nach der verbundenen Zelle Teilen.
Sub Liste_aufteilen()
Dim WorkRng As Range
Dim xRow As Range
Dim SplitRow As Integer
Dim xWs As Worksheet
Dim xTRg As Range
Dim xNTRg As Range
Dim xIER As Integer
On Error Resume Next
xTitleId = "Liste_Aufteilen"
Set WorkRng = Application.Selection
If TypeName(WorkRng) = "Nothing" Then Exit Sub
Set xTRg = Application.InputBox("Please select the header row:", xTitleId, "", Type:=8)
Set WorkRng = Application.InputBox("Please select the data range(exclude the header row):", xTitleId, WorkRng.Address, Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
SplitRow = Application.InputBox("Split Row Num", xTitleId, Type:=1)
If SplitRow = 0 Then Exit Sub
Set xWs = WorkRng.Parent
Set xRow = WorkRng.Rows(1)
xIER = WorkRng.Rows(WorkRng.Rows.Count).Row
Application.ScreenUpdating = False
For i = 1 To WorkRng.Rows.Count Step SplitRow
resizeCount = SplitRow
If (xIER - xRow.Row + 1) (xRow.Row + SplitRow - 1) Then
xWs.Name = xRow.Row & " - " & (xRow.Row + SplitRow - 1)
ElseIf xIER = xRow.Row Then
xWs.Name = xRow.Row
Else
xWs.Name = xRow.Row & " - " & xIER
End If
Application.ActiveSheet.Range("A1").PasteSpecial
Application.ActiveSheet.Range("A1").PasteSpecial Paste:=8
Set xNTRg = Application.ActiveSheet.Range("A1")
xTRg.Copy
xNTRg.Insert
Set xRow = xRow.Offset(SplitRow)
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
