Makro ausführen ohne Öffnen von Zieldatei
15.01.2020 14:33:02
Zieldatei
ich habe folgende Code und funktioniert sehr gut.
Nun versuche ich, dass ich diese Makro in andere Exceldatei "Makro.xlsm zu schreiben und diese Code muss laufen ohne das man die Zieldatei "Abfrage_Export_GE1.xlsm" öffnet.
Könnte mir bitte jemand mir dabei helfen? Wäre mega nett.
Danke schön im Voraus.
Al
Option Explicit
Sub GetAllUpdatesM()
Dim lLastRow As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim intCalculation As Integer
Dim Pfad As String
Const Abfrage_Export_DE As String = "R:\02_AUSWERTUNG\Abfrage_Export_DE.xlsx"
Const Abfrage_Export_EN As String = "R:\02_AUSWERTUNG\Abfrage_Export_EN.xlsx"
Application.ScreenUpdating = False
Application.EnableEvents = False
intCalculation = Application.Calculation
Application.Calculation = xlManual
Set wkbOld = ActiveWorkbook
Application.StatusBar = "delete old data"
With wkbOld.Sheets("Abfrage_Export_GE1")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 2 Then
.Range("A3:" & .UsedRange.SpecialCells(xlCellTypeLastCell).Address).ClearContents
End If
End With
Application.StatusBar = "check if worksheet in this file does exist"
If WorksheetExists("Abfrage_Export_GE1") Then
Sheets("Abfrage_Export_GE1").Activate
Else
Application.StatusBar = "create missing worksheet"
Sheets.Add
ActiveSheet.Name = " Abfrage_Export_GE1"
Sheets("Abfrage_Export_GE1").Activate
End If
Application.StatusBar = "check if workbook " & Abfrage_Export_DE & " does exist, and open it"
If WkbExists(Abfrage_Export_DE) = False Then
If Dir(Abfrage_Export_DE) = "" Then
Else
Workbooks.Open Abfrage_Export_DE, UpdateLinks:=False
End If
Else
Workbooks(Abfrage_Export_DE).Activate
End If
Application.StatusBar = "check if worksheet in external file does exist"
Set wkbNew = ActiveWorkbook
If Not WorksheetExists("Abfrage_Export_DE") Then
Else
Application.StatusBar = "copy data"
wkbNew.Sheets("Abfrage_Export_DE").Activate
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wkbNew.ActiveSheet.Range("A2:AT" & lLastRow).Copy
Application.StatusBar = "paste data"
wkbOld.Sheets("Abfrage_Export_GE1").Range("A2").PasteSpecial xlPasteValues
wkbOld.Sheets("Abfrage_Export_GE1").Range("A2").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.StatusBar = "close file"
wkbNew.Close False
Application.StatusBar = "check if workbook " & Abfrage_Export_EN & " does exist, and open it"
If WkbExists(Abfrage_Export_EN) = False Then
If Dir(Abfrage_Export_EN) = "" Then
Else
Workbooks.Open Abfrage_Export_EN, UpdateLinks:=False
End If
Else
Workbooks(Abfrage_Export_EN).Activate
End If
Application.StatusBar = "check if worksheet in external file does exist"
Set wkbNew = ActiveWorkbook
If Not WorksheetExists("Abfrage_Export_EN") Then
Else
Application.StatusBar = "copy data"
wkbNew.Sheets("Abfrage_Export_EN").Activate
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wkbNew.ActiveSheet.Range("A2:AT" & lLastRow).Copy
Application.StatusBar = "paste data"
lLastRow = wkbOld.Sheets("Abfrage_Export_GE1").Cells(wkbOld.Sheets("Abfrage_Export_GE1").Rows.Count, 1).End(xlUp).Row + 1
wkbOld.Sheets("Abfrage_Export_GE1").Range("A" & lLastRow).PasteSpecial xlPasteValues
wkbOld.Sheets("Abfrage_Export_GE1").Range("A" & lLastRow).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.StatusBar = "close file"
wkbNew.Close False
Application.StatusBar = "copy formulas"
With wkbOld.Sheets("Abfrage_Export_GE1")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 2 Then
.Range("AW2:CJ2").Copy
.Range("AW3:CJ" & lLastRow).PasteSpecial
Application.CutCopyMode = False
End If
End With
Call TextInSpalten(wkbOld.Sheets("Abfrage_Export_GE1"))
Application.StatusBar = ""
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
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
Sub TextInSpalten(ws As Worksheet)
Dim mySpalten As Variant
Dim s As Variant
mySpalten = Array("I", "K", "L", "M", "N", "O", "Q", "S", "T", "U", "V", "W", "X", "Z", "AA", "AB", "AC", "AH", "AI", "AJ", "AM", "AP", "AQ", "AR", "AS") ' ensprechend anpaasen
For Each s In mySpalten
ws.Columns(s).TextToColumns Destination:=ws.Range(s & "1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Next
MsgBox "Daten wurden erfolgreich kopiert!"
End Sub