AW: 2 Blätter aus 2 Datein zusammenführen
08.11.2019 10:00:12
Klaus
Hallo Robert,
bei mir funktioniert es so:
Option Explicit
Sub GetAllUpdates()
On Error GoTo skipthis
Dim lLastRow As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim intCalculation As Integer
Const ExportD As String = "H:\herber\Export D.xlsx"
Const ExportF As String = "H:\herber\Export F.xlsx"
Application.ScreenUpdating = False
Application.EnableEvents = False
intCalculation = Application.Calculation
Application.Calculation = xlManual
Set wkbOld = ActiveWorkbook
Application.StatusBar = "delete old data"
With wkbOld.Sheets("Ausblick")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 5 Then .Range("A5:AU" & lLastRow).ClearContents
End With
Application.StatusBar = "check if worksheet in this file does exist"
If WorksheetExists("Ausblick") Then
Sheets("Ausblick").Activate
Else
Application.StatusBar = "create missing worksheet"
Sheets.Add
ActiveSheet.Name = "Ausblick"
Sheets("Ausblick").Activate
End If
Application.StatusBar = "check if workbook " & ExportD & " does exist, and open it"
If WkbExists(ExportD) = False Then
If Dir(ExportD) = "" Then
GoTo skipthis
Else
Workbooks.Open ExportD, UpdateLinks:=False
End If
Else
Workbooks(ExportD).Activate
End If
Application.StatusBar = "check if worksheet in external file does exist"
Set wkbNew = ActiveWorkbook
If Not WorksheetExists("Daten") Then
GoTo skipthis
Else
Application.StatusBar = "copy data"
wkbNew.Sheets("Daten").Activate
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wkbNew.ActiveSheet.Range("A2:AU" & lLastRow).Copy
Application.StatusBar = "paste data"
wkbOld.Sheets("Ausblick").Range("A5").PasteSpecial xlPasteValues
wkbOld.Sheets("Ausblick").Range("A5").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.StatusBar = "close file"
wkbNew.Close False
Application.StatusBar = "check if workbook " & ExportF & " does exist, and open it"
If WkbExists(ExportF) = False Then
If Dir(ExportF) = "" Then
GoTo skipthis
Else
Workbooks.Open ExportF, UpdateLinks:=False
End If
Else
Workbooks(ExportF).Activate
End If
Application.StatusBar = "check if worksheet in external file does exist"
Set wkbNew = ActiveWorkbook
If Not WorksheetExists("Daten") Then
GoTo skipthis
Else
Application.StatusBar = "copy data"
wkbNew.Sheets("Daten").Activate
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wkbNew.ActiveSheet.Range("A2:AU" & lLastRow).Copy
Application.StatusBar = "paste data"
lLastRow = wkbOld.Sheets("Ausblick").Cells(wkbOld.Sheets("Ausblick").Rows.Count, 1).End( _
xlUp).Row + 1
wkbOld.Sheets("Ausblick").Range("A" & lLastRow).PasteSpecial xlPasteValues
wkbOld.Sheets("Ausblick").Range("A" & lLastRow).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.StatusBar = "close file"
wkbNew.Close False
Application.StatusBar = "copy formulas"
With wkbOld.Sheets("Ausblick")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 5 Then
.Range("AW5:BC5").Copy
.Range("AW6:BC" & lLastRow).PasteSpecial
Application.CutCopyMode = False
End If
End With
GoTo heaven
skipthis:
MsgBox ("Es gab einen Fehler - Wahrscheinlich stimmt eine Pfadangabe nicht")
heaven:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = intCalculation
End Sub
Private Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name "")
On Error GoTo 0
End Function
LG,
Klaus M.