AW: Abspeichern mehrerer Tabellen in versch. Büchern
26.05.2014 11:21:17
Achim
... hier wäre dann der Code; ich hoffe, Du/Ihr werdet daraus schlau .... ;-)
Sub Abheften()
Dim ws As Worksheet, twb As Workbook, ablagePfad As String, awb As Workbook, aws As _
Worksheet
Dim i As Integer, BlattPos As Integer, AbheftungErfolg As Byte
If strSUVorgabe(6) = "Nein" Then Exit Sub
Set twb = ThisWorkbook
ablagePfad = pruefePfadZeichenkette(strSUVorgabe(1) & "\" & strSUVorgabe(2))
AbheftungErfolg = 0
For i = 1 To UBound(AblageBuecher)
'wenn Datei existiert, dann öffnen
If existiertOrdnerDatei(ablagePfad & AblageBuecher(i), 1) = True Then
Application.ScreenUpdating = False
If AblageBuecher(i) = WBNameSaA & ".xls" Then
'Samstagsblätter
If offenWB(AblageBuecher(i)) = False Then Application.Workbooks.Open _
Filename:=ablagePfad & AblageBuecher(i)
Set awb = Workbooks(AblageBuecher(i))
'für jedes Tabellenblatt in diesemWB, dass nicht Einstellungen oder Externe _
Produktion heisst,
For Each ws In twb.Worksheets
If Not ws.Name = "Einstellungen" And Not Left(ws.Name, 7) = "Externe" _
Then
For Each aws In awb.Worksheets 'AblageBuch von vorne nach hinten prü _
fen, ob Name = "Tabelle"
If Left(awb.Worksheets(aws.Index).Name, 7) = "Tabelle" Then
twb.Worksheets(ws.Index).Cells.Copy Destination:=awb. _
Worksheets(aws.Index).Cells
awb.Worksheets(aws.Index).Name = twb.Worksheets(ws.Index). _
Name
Exit For
ElseIf awb.Worksheets(aws.Index).Name = twb.Worksheets(ws.Index) _
.Name Then 'oder das abzulgende Blatt bereits vorhanden ist, dann Rückfrage
If MsgBox("Das Blatt " & twb.Worksheets(ws.Index).Name & " _
ist bereits vorhanden," & vbLf & "soll es überschrieben werden?", vbYesNo Or vbQuestion, "Hinweis") = vbYes Then
twb.Worksheets(ws.Index).Cells.Copy Destination:=awb. _
Worksheets(aws.Index).Cells
awb.Worksheets(aws.Index).Name = twb.Worksheets(ws. _
Index).Name
Exit For
Else
Exit For
End If
Else 'sonst hinten anfügen
'hier weiter ...., neues Tabellenblatt hinzufügen und zu _
sicherndes Blatt drauf kopieren.
If ws.Index = twb.Worksheets.Count Then
awb.Worksheets.Add after:=awb.Worksheets(awb.Worksheets. _
Count)
twb.Worksheets(ws.Index).Cells.Copy _
Destination:=awb.Worksheets(awb.Worksheets. _
Count).Cells
awb.Worksheets(awb.Worksheets.Count).Name = twb. _
Worksheets(ws.Index).Name
Exit For
End If
End If
Next aws
End If
Next ws
'WB speichern und schließen
awb.Close savechanges:=True
Else
'öffnen
If offenWB(AblageBuecher(i)) = False Then Application.Workbooks.Open _
Filename:=ablagePfad & AblageBuecher(i)
Set awb = Workbooks(AblageBuecher(i))
For Each ws In awb.Worksheets 'prüfen, ob Blatt mit dem Namen bereits _
vorhanden ist
If ws.Name = abzulegendeBlaetter(i) Then
'ja: überschreiben
twb.Worksheets(abzulegendeBlaetter(i)).Cells.Copy _
Destination:=awb.Worksheets(ws.Index).Cells
awb.Close savechanges:=True
AbheftungErfolg = 1
Exit For
Else
If Left(ws.Name, 7) = "Tabelle" Then
'BlattPos = ws.Index
twb.Worksheets(abzulegendeBlaetter(i)).Cells.Copy _
Destination:=awb.Worksheets(ws.Index).Cells
awb.Worksheets(ws.Index).Name = abzulegendeBlaetter(i)
awb.Close savechanges:=True
AbheftungErfolg = 1
Exit For
End If
End If
Next ws
If AbheftungErfolg = 0 Then
'neues Blatt anlegen
awb.Worksheets.Add after:=awb.Worksheets(awb.Worksheets.Count)
twb.Worksheets(abzulegendeBlaetter(i)).Cells.Copy _
Destination:=awb.Worksheets(awb.Worksheets.Count).Cells
awb.Worksheets(awb.Worksheets.Count).Name = abzulegendeBlaetter(i)
awb.Close savechanges:=True
End If
End If
Application.ScreenUpdating = True
Else
'sonst Fehlermeldung ausgeben
End If
AbheftungErfolg = 0
Next i
End Sub