@ Matthias G: Brauche Dich nochmal
27.10.2005 09:22:54
Daniel
vor einiger Zeit hattest du mir ein Makro erstellt, dass aus mehreren Dateien ein Blatt in eine "Masterdatei" kopiert.
Nun muss ich ein weiteres Blatt hinzufügen, weiß aber nicht wie ich das genau mache. Ich habe mir zwar den Code genau angesehen, komme aber im Moment nicht weit.
Neben dem Blatt "Auswertung" soll noch das Blatt "Bericht" kopiert werden.
Nun aber nicht in die Blätter mit den Namen sondern in die Blätter Namen_Bericht.
Vielleicht kann man das ja in der vorhandenen Funktion ergänzen?
Ich hoffe Du kannst mir nochmal helfen....
Beste Grüße,
Daniel
Hier noch der Code:
'Funktion prüft, ob angegebene Mappe geöffnet ist. Rückgabewert: True oder False
Function WBIsOpen(ByVal n As String) As Boolean
Dim wb As Workbook
For Each wb In Workbooks
If UCase(wb.Name) = UCase(n) Then
WBIsOpen = True
Exit Function
End If
Next wb
WBIsOpen = False
End Function
'Funktion prüft, ob angegebener Tabellenblattname vorhanden ist. Rückgabewert: True oder False
Function WSExists(wb As Workbook, ByVal n As String) As Boolean
Dim ws As Worksheet
For Each ws In wb.Sheets
If UCase(ws.Name) = UCase(n) Then
WSExists = True
Exit Function
End If
Next ws
WSExists = False
End Function
Sub Kopieren()
Dim i As Integer, n As String
Dim ActSh As Worksheet
Dim erg As String, WarFehler As Boolean
i = 1
n = ThisWorkbook.Sheets("Namen").Cells(i, 1)
WarFehler = False
If UserForm1.Visible = True Then Unload UserForm1
Set ActSh = ActiveSheet 'aktuelles Blatt merken
'Meldung anzeigen
With UserForm1
.SchliessenButton.Enabled = False
.Show False 'nichtmodal anzeigen, d.h. es wird nicht aufs Schließen der UF gewartet
Application.ScreenUpdating = False 'Bildschirmaktualisierung abschalten
End With
Do While n <> ""
UserForm1.TextBox1 = UserForm1.TextBox1 & vbLf & "Mappe wird aus """ & n & ".xls" & """ aktualisiert..."
DoEvents
erg = KopiereBlatt(ThisWorkbook.Path, n & ".xls", "Auswertung", n)
If erg = "" Then
UserForm1.TextBox1 = UserForm1.TextBox1 & "OK" & vbLf
Else
WarFehler = True
UserForm1.TextBox1 = UserForm1.TextBox1 & vbLf & "FEHLER:" & erg & vbLf
End If
i = i + 1
n = ThisWorkbook.Sheets("Namen").Cells(i, 1)
Loop
If WarFehler Then
'Wenn Fehler, dann auf Bestätigung warten
UserForm1.SchliessenButton.Enabled = True
Else
'sonst Userform gleich schließen
Unload UserForm1
End If
ActSh.Activate 'Blatt wieder aktivieren (falls neue Blätter erzeugt werden mussten)
'Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
End Sub
'Kopierroutine
Function KopiereBlatt(QMappe_Pfad As String, QMappe_Name As String, _
QBlatt_Name As String, ZBlatt_Name As String) As String
'Debug.Print QMappe_Pfad, QMappe_Name, QBlatt_Name, ZBlatt_Name
'Exit Sub
Dim WB_Q As Workbook
Dim WS_Q As Worksheet
Dim WS_Z As Worksheet
Dim Zieloffen As Boolean
Dim ErrMsg As String 'Fehlermeldung, bei möglichen Fehlern
On Error GoTo ERRHANDLER
'Mappe Master.xls bei Bedarf schreibgeschützt öffnen
If Not WBIsOpen(QMappe_Name) Then
ErrMsg = "Fehler beim Öffnen von """ & QMappe_Pfad & "\" & QMappe_Name & """"
Application.EnableEvents = False '<<< NEU
Workbooks.Open QMappe_Pfad & "\" & QMappe_Name, ReadOnly:=True, UpdateLinks:=True '<<< NEU
Application.EnableEvents = True '<<< NEU
ErrMsg = ""
Zieloffen = False
Else
Zieloffen = True
End If
'Prüfen, on Blatt existiert, b.B. erstellen
If Not WSExists(ThisWorkbook, ZBlatt_Name) Then
ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(Sheets.Count)
ThisWorkbook.ActiveSheet.Name = ZBlatt_Name
End If
'Variablen zuweisen
Set WS_Z = ThisWorkbook.Sheets(ZBlatt_Name)
Set WB_Q = Workbooks(QMappe_Name)
ErrMsg = "Blatt """ & QBlatt_Name & """ in " & QMappe_Name & " nicht vorhanden!"
Set WS_Q = WB_Q.Sheets(QBlatt_Name)
ErrMsg = ""
WS_Z.Cells.Delete 'Blattinhalt löschen
WS_Q.Cells.Copy 'Blattinhalt kopieren
'in Blatt Schmidt einfügen:
With WS_Z.Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
'.Select
End With
Application.CutCopyMode = False 'Kopiermarkiereung entfernen
'Quellmappe wieder schließen, wenn sie extra geöffnet wurde
If Not Zieloffen Then WB_Q.Close SaveChanges:=False
KopiereBlatt = ""
Exit Function
ERRHANDLER:
KopiereBlatt = IIf(ErrMsg = "", Err.Description, ErrMsg)
Err.Clear
End Function