Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen

Druckbereich, Sperrung, Autofilter Split

Betrifft: Druckbereich, Sperrung, Autofilter Split von: Tina
Geschrieben am: 03.09.2020 10:36:27

Guten Tag,

ich nutze diesen Code und er funktioniert auch super, er sucht mir aus einer Tabelle nach verschiedenen Kürzeln und erstellt einzelne neue Worksheets unter dem Kürzelnamen.

Sub A_Tabelle_nach Kürzel splitten()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type: _
=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", " _
Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws. _
Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells( _
xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & ""). _
Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub
Jetzt habe ich allerdings folgendes Problem:
Ich möchte, dass es mir aus der Gesamtabelle den Druckbereich immer mit übernimmt, sowie die Spaltenbreite, Sperrungen, Autofilter und die Fixierung eines Fensters.
Ist so etwas möglich? Kann mir jemand weiterhelfen?

Betrifft: AW: Druckbereich, Sperrung, Autofilter Split
von: fcs
Geschrieben am: 04.09.2020 10:17:51

Hallo Tina,

ich hab deine Wunschliste in das Makro eingearbeitet.

Dazu wird das Blatt mit den Daten kopiert und die Daten unterhalb der Titelzeilen gelöscht.
Dieses Blatt wird dann als Vorlage für jedes Kürzel kopiert, statt neue Blätter anzufügen.
Zum Schluss wird die Vorlage wieder gelöscht.
So werden alle Formatierungen und Einstellungen aus dem Original-Blatt übernommen.

LG
Franz

Textdatei mit dem modifizierten Makro:
https://www.herber.de/bbs/user/140039.txt

Beiträge aus dem Excel-Forum zum Thema "Druckbereich, Sperrung, Autofilter Split"