AW: Öffnen, schließen, und aktivieren
10.10.2019 13:04:39
Dieter
Hallo eho,
das Programm könnte so aussehen. Ggf. musst du deine Angaben noch etwas präzisieren. Ich verwende diejenige Arbeitsmappe, die das VBA-Programm enthält als Zieldatei, kopiere aus Spalte A der Quelle und füge in Spalte A der Zieldatei ein.
Sub DatenÜbernehmen()
Dim dateiQ As String
Dim fd As FileDialog
Dim letzteZeileQ As Long
Dim letzteZeileZ As Long
Dim pfadDateiQ As String
Dim pfadQ As String
Dim wbQ As Workbook
Dim wbZ As Workbook
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Set wbZ = ThisWorkbook
If Not BlattExistiert(wbZ, "STUNDEN") Then
MsgBox "Blatt ""STUNDEN"" existiert nicht"
Exit Sub
End If
Set wsZ = wbZ.Worksheets("STUNDEN")
pfadQ = wbZ.Path & "\"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = pfadQ
If fd.Show = 0 Then
MsgBox "Benutzerabbruch"
Exit Sub
End If
pfadDateiQ = fd.SelectedItems(1)
dateiQ = Right$(pfadDateiQ, Len(pfadDateiQ) - InStrRev(pfadDateiQ, "\"))
Set wbQ = Workbooks.Open(pfadDateiQ)
If Not BlattExistiert(wbQ, "Export") Then
MsgBox "Blatt ""Export"" existiert nicht"
Exit Sub
End If
Set wsQ = wbQ.Worksheets("Export")
letzteZeileQ = wsQ.Cells(wsQ.Rows.Count, "A").End(xlUp).Row
If letzteZeileQ > 1 Then
wsQ.Cells(2, "A").Resize(letzteZeileQ - 1).Copy
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "A").End(xlUp).Row
wsZ.Cells(letzteZeileZ + 1, "A").PasteSpecial Paste:=xlValues
Application.CutCopyMode = xlCut
End If
wbQ.Close SaveChanges:=True
If Not BlattExistiert(wbZ, "Start") Then
MsgBox "Blatt ""START"" existiert nicht"
Exit Sub
End If
wbZ.Worksheets("START").Activate
End Sub
Function BlattExistiert(Mappe As Workbook, _
BlattName As String) As Boolean
Dim ws As Worksheet
For Each ws In Mappe.Worksheets
If UCase$(BlattName) = UCase$(ws.Name) Then
BlattExistiert = True
Exit Function
End If
Next ws
End Function
https://www.herber.de/bbs/user/132464.xlsm
Viele Grüße
Dieter