Anpassung für mehrere Blätter
29.03.2016 10:26:49
Michael
Hallo Metin!
Hier die gewünschte Anpassung für mehrere Blätter in der Quellmappe. Ich bin allerdings davon ausgegangen, dass der Datenbereich in allen Blättern gleich ist (also die "x"-Kennzeichnung in jedem Blatt von A1:AD1 reicht):
Wie bisher in das Klassenmodul der Arbeitsmappe (Quellmappe!)...
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call SpaltenXkopieren
End Sub
... in ein allgemeines Modul der Quellmappe:
Sub SpaltenXkopieren()
Dim SuBereich As Range
Dim Zelle As Range
Dim KopierBereich As Range
Dim QuellMappe As Workbook
Dim ZielMappe As Workbook
Dim i As Long
Const BereichX As String = "A1:AD1" 'Wo stehen die "x", anpassen
Const ZielPfad As String = "C:\Dokumente\" 'Wo soll gespeichert werden, anpassen
Const ZielDatei As String = "Dateiname" 'Welcher Dateiname, anpassen
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set QuellMappe = ThisWorkbook
Set ZielMappe = Workbooks.Add
With ZielMappe
For i = 1 To QuellMappe.Worksheets.Count - 1
.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
Next i
End With
For i = 1 To QuellMappe.Worksheets.Count
Set SuBereich = QuellMappe.Worksheets(i).Range(BereichX)
For Each Zelle In SuBereich
If Zelle.Text = "x" Then
If KopierBereich Is Nothing Then
Set KopierBereich = Zelle.EntireColumn
Else:
Set KopierBereich = _
Union(KopierBereich, Zelle.EntireColumn)
End If
End If
Next Zelle
With ZielMappe
KopierBereich.Copy .Worksheets(i).Range("A1")
.Worksheets(i).Range("A1").EntireRow.Delete
End With
Set KopierBereich = Nothing
Application.CutCopyMode = False
Next i
With ZielMappe
.Worksheets(1).Activate
.SaveAs Filename:=ZielPfad & ZielDatei, FileFormat:=51
.Close savechanges:=True
End With
Set QuellMappe = Nothing
Set ZielMappe = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
Ein paar allgemeine Anpassungen kannst Du hier vornehmen; sollte sich der Zielpfad, der Ziel-Dateiname oder auch der "x"-Kennzeichnungsbereich (bisher A1:AD1) ändern, musst Du das nur hier einmalig anpassen:
Const BereichX As String = "A1:AD1" 'Wo stehen die "x", anpassen
Const ZielPfad As String = "C:\Dokumente\" 'Wo soll gespeichert werden, anpassen
Const ZielDatei As String = "Dateiname" 'Welcher Dateiname, anpassen
LG
Michael