Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 21:51:33
Idee für Grafik
26.04.2024 21:29:07
PQ zufällige Reihenfolge
26.04.2024 17:18:47
Große Datenmenge in komplexes Diagramm verpacken
26.04.2024 16:22:47
Aktualisierung Verknüpfung bei geschlossener Quelldatei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1604to1608
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1604to1608
1604to1608
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Workbook.open

Workbook.open
23.01.2018 09:34:58
Georg
Liebe Mitglieder, der folgende Code wurde mit Unterstützung erstellt.
Wie ihr seht wird ein bestimmter Pfad + Datei ausgewählt und diese wird dann entsprechend bearbeitet.
Was ich möchte:
Geöffnet ist die Vorlagendatei (WbZ), darüber soll dann der Anwender anstatt diesem festgelegten Pfad und Datei ein Fenster bekommen, wo er eine Datei auswählen kann.
Für diese Datei sollen dann sämtliche Befehle wie Kopieren etc wie im Code angegeben durchgeführt werden.
Meine Kenntnisse reichen i-wie nicht aus, über Work.book open und application.getopenfilename krieg es nicht hin. Wahrscheinlich kann man auch die Umbenennung der Sheets eleganter lösen, aber das ist zweitrangig.
Der momentane Code: 
Sub Murnau()
'1 Überträge kopieren
Dim WbZ As Workbook: Set WbZ = ThisWorkbook 'Ziel-Mappe = DIE Vorlagen-Mappe
Dim WbQ As Workbook, Datei$, i&
Dim dialog As Object
Dim fileSaveName As Variant
Dim Pfad As Variant
Pfad = "Q:\Personal Leitung\Abrechnung\Gehaltsläufe\2016\BPx\" 'schließenden "\" beachten
Datei = "201_Murnau_Personalabrechnung_2016.xlsm"
Application.ScreenUpdating = False
Set WbQ = Workbooks.Open(Pfad & Datei)
For i = 3 To 17
WbZ.Worksheets(i).Range("J38") = WbQ.Worksheets(i).Range("I248")
Next i
WbQ.Close False 'Optional Quell-Mappe ohne Speichern schließen
'2 Buttons Löschen
On Error Resume Next
For i = 1 To 1
ActiveWorkbook.Sheets(i).Buttons.Delete
Next i
'3 Daten kopieren
Set WbQ = Workbooks.Open(Pfad & Datei)
Sheets(1).Select
Range("B3:F22").Select
Selection.Copy
WbZ.Activate
Sheets("BPx Stammdaten").Activate
Range("b3").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'ActiveWindow.Close
WbQ.Activate
Sheets("AZDaten").Activate
Range("c18:M33").Select
Selection.Copy
WbZ.Activate
Sheets("AZDaten").Activate
Range("c18").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False
WbQ.Close
'ActiveWindow.Close 'letzte Zeile
Application.DisplayAlterts = True
'4 Sheets umbenennen
ThisWorkbook.Activate
Sheets("MA1").Select
Sheets("MA1").Name = Sheets("BPx Stammdaten").Range("C8")
Sheets("MA2").Select
Sheets("MA2").Name = Sheets("BPx Stammdaten").Range("C9")
Sheets("MA3").Select
Sheets("MA3").Name = Sheets("BPx Stammdaten").Range("C10")
Sheets("MA4").Select
Sheets("MA4").Name = Sheets("BPx Stammdaten").Range("C11")
Sheets("MA5").Select
Sheets("MA5").Name = Sheets("BPx Stammdaten").Range("C12")
Sheets("MA6").Select
Sheets("MA6").Name = Sheets("BPx Stammdaten").Range("C13")
Sheets("MA7").Select
Sheets("MA7").Name = Sheets("BPx Stammdaten").Range("C14")
Sheets("MA8").Select
Sheets("MA8").Name = Sheets("BPx Stammdaten").Range("C15")
Sheets("MA9").Select
Sheets("MA9").Name = Sheets("BPx Stammdaten").Range("C16")
Sheets("MA10").Select
Sheets("MA10").Name = Sheets("BPx Stammdaten").Range("C17")
Sheets("MA11").Select
Sheets("MA11").Name = Sheets("BPx Stammdaten").Range("C18")
Sheets("MA12").Select
Sheets("MA12").Name = Sheets("BPx Stammdaten").Range("C19")
Sheets("MA13").Select
Sheets("MA13").Name = Sheets("BPx Stammdaten").Range("C20")
Sheets("MA14").Select
Sheets("MA14").Name = Sheets("BPx Stammdaten").Range("C21")
Sheets("MA15").Select
Sheets("MA15").Name = Sheets("BPx Stammdaten").Range("C22")
Sheets("BPx Stammdaten").Select
Sheets("BPx Stammdaten").Name = Sheets("AZDaten").Range("R5")
Sheets("BPx_Abrechnung").Select
Sheets("BPx_Abrechnung").Name = Sheets("AZDaten").Range("Q6")
ActiveWorkbook.Sheets(2).Unprotect Password:="Personal"
End Sub

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Workbook.open
23.01.2018 09:57:40
chao.soft
Hi Georg,
versuch mal ob dir der folgende Code hilft. Er müsste direkt nach "Dim Pfad as Variant" eingefügt werden.
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Daten übernehmen"
.Filters.Clear
.Filters.Add "Excel-Arbeitsmappe", "*.xlsm", 1
.AllowMultiSelect = False
.Show
wsQuelle = .SelectedItems(1)
End With
Datei = Right(wsQuelle, InStr(1, StrReverse(wsQuelle), "\") - 1)
Pfad = Replace(wsQuelle, datei, "")
Ich habe den Code nicht getestet, sollte irgendetwas nicht funktionieren, melde dich einfach nochmal.
Beste Grüße
chaosoft
Anzeige
AW: Workbook.open
23.01.2018 10:03:38
yummi
Hallo Georg,
schau mal, ob das dem entspricht, was Du willst:

Sub Murnau()
'1 Überträge kopieren
Dim WbZ As Workbook: Set WbZ = ThisWorkbook 'Ziel-Mappe = DIE Vorlagen-Mappe
Dim WbQ As Workbook, Datei$
Dim dialog As Object
Dim fileSaveName As Variant
Dim Pfad As Variant
Dim strfilter as String
Dim strFileName as String
Dim i as Integer
'** Dateifilter definieren
strFilter = "Excel-Dateien(*.xl*), *.xl*"
'Pfad = "Q:\Personal Leitung\Abrechnung\Gehaltsläufe\2016\BPx\" 'schließenden "\" beachten
'Datei = "201_Murnau_Personalabrechnung_2016.xlsm"
'** Laufwerk und Pfad definieren, welcher geöffnet werden soll, wenn C:\ geöffnet werden soll,  _
einfach weglassen
ChDrive "Q"
ChDir "Q:\Personal Leitung\Abrechnung\Gehaltsläufe\2016\BPx"
'** Den im Dialogfeld gewählten Namen auslesen
strFileName = Application.GetOpenFilename(strFilter)
'** Prüfen, ob eine gültige Datei ausgewählt wurde
If strFileName = False Then Exit Sub
Application.ScreenUpdating = False
'** Gewählte Datei öffnen
Set WbQ = Workbooks.Open(strFileName)
'Set WbQ = Workbooks.Open(Pfad & Datei)
For i = 3 To 17
WbZ.Worksheets(i).Range("J38") = WbQ.Worksheets(i).Range("I248")
Next i
WbQ.Close False 'Optional Quell-Mappe ohne Speichern schließen
'2 Buttons Löschen
On Error Resume Next
For i = 1 To 1
ActiveWorkbook.Sheets(i).Buttons.Delete
Next i
'3 Daten kopieren
Set WbQ = Workbooks.Open(Pfad & Datei)
Sheets(1).Select
Range("B3:F22").Select
Selection.Copy
WbZ.Activate
Sheets("BPx Stammdaten").Activate
Range("b3").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'ActiveWindow.Close
WbQ.Activate
Sheets("AZDaten").Activate
Range("c18:M33").Select
Selection.Copy
WbZ.Activate
Sheets("AZDaten").Activate
Range("c18").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False
WbQ.Close
'ActiveWindow.Close 'letzte Zeile
Application.DisplayAlterts = True
'4 Sheets umbenennen
ThisWorkbook.Activate
for i = 1 to 15
ThisWorkbook.Sheets("MA" & i).Name = Sheets("BPx Stammdaten").Range("C" & i+7)
next i
with ThisWorkbook
.Sheets("BPx Stammdaten").Name = Sheets("AZDaten").Range("R5")
.Sheets("BPx_Abrechnung").Name = Sheets("AZDaten").Range("Q6")
end with
ActiveWorkbook.Sheets(2).Unprotect Password:="Personal"
End Sub
Gruß
yummi
Anzeige
AW: Workbook.open
23.01.2018 10:52:39
Georg
Hallo der code sieht jetzt wie folgt aus, leider passiert nichts. Für den Filter: die Quelle ist auch eine xlsm Datei, ich bekomme mom. eine Meldung Typen unverträgllich. Wenn ich die Zeile auskommentiere, läuft der Code durch bis zum Speichern, die gespeicherte Datei hat aber keine Werte aus der Quelldatei?
Noch j-d eine Idee?
Option Explicit 
Sub Murnau()
'1 Überträge kopieren
Dim WbZ As Workbook: Set WbZ = ThisWorkbook 'Ziel-Mappe = DIE Vorlagen-Mappe
Dim WbQ As Workbook, Datei$
Dim dialog As Object
Dim fileSaveName As Variant
Dim Pfad As Variant
Dim strfilter As String
Dim strFileName As String
Dim i As Integer
'** Dateifilter definieren
strfilter = "Excel-Dateien(*.xl*), *.xl*"
'Pfad = "Q:\Personal Leitung\Abrechnung\Gehaltsläufe\2016\BPx\" 'schließenden "\" beachten
'Datei = "201_Murnau_Personalabrechnung_2016.xlsm"
'** Laufwerk und Pfad definieren, welcher geöffnet werden soll, wenn C:\ geöffnet werden  _
soll, _
einfach weglassen
ChDrive "Q"
ChDir "Q:\Personalwesen\Sonstige\Personalplanung\Entwürfe_Temp(GR)"
'** Den im Dialogfeld gewählten Namen auslesen
strFileName = Application.GetOpenFilename(strfilter)
'** Prüfen, ob eine gültige Datei ausgewählt wurde
If strFileName = False Then Exit Sub
Application.ScreenUpdating = False
'** Gewählte Datei öffnen
Set WbQ = Workbooks.Open(strFileName)
'Set WbQ = Workbooks.Open(Pfad & Datei)
For i = 3 To 19
WbZ.Worksheets(i).range("J38") = WbQ.Worksheets(i).range("I248")
Next i
WbQ.Close False 'Optional Quell-Mappe ohne Speichern schließen
'2 Buttons Löschen
On Error Resume Next
For i = 1 To 1
ActiveWorkbook.Sheets(i).Buttons.Delete
Next i
'3 Daten kopieren
Set WbQ = Workbooks.Open(Pfad & Datei)
Sheets(1).Select
range("B3:F22").Select
Selection.Copy
WbZ.Activate
Sheets("BPx Stammdaten").Activate
range("b3").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'ActiveWindow.Close
WbQ.Activate
Sheets("AZDaten").Activate
range("c18:M33").Select
Selection.Copy
WbZ.Activate
Sheets("AZDaten").Activate
range("c18").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False
WbQ.Close
'ActiveWindow.Close 'letzte Zeile
Application.DisplayAlterts = True
'4 Sheets umbenennen
ThisWorkbook.Activate
For i = 1 To 15
ThisWorkbook.Sheets("MA" & i).Name = Sheets("BPx Stammdaten").range("C" & i + 7)
Next i
With ThisWorkbook
.Sheets("BPx Stammdaten").Name = Sheets("AZDaten").range("R5")
.Sheets("BPx_Abrechnung").Name = Sheets("AZDaten").range("Q6")
End With
ActiveWorkbook.Sheets(2).Unprotect Password:="Personal"
' 5 Speichern
'Pfad = "Q:\Personal Leitung\Abrechnung\Gehaltsläufe\2017\BPx\"
'Set dialog = Application.FileDialog(msoFileDialogSaveAs)
'With dialog
'.InitialFileName = Pfad
'.Show
'End With
'If dialog  False Then dialog.Execute
fileSaveName = Application.GetSaveAsFilename( _
InitialFileName:="Q:\Personalwesen\sonstige\" & _
"Pesonalplanung\Entwürfe_Temp(GR)\Test.xlsm", _
filefilter:="Excel File mit Makro (*.xlsm), *.xlsm")
If VarType(fileSaveName) = vbString Then
ThisWorkbook.SaveAs _
Filename:=fileSaveName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
MsgBox "Sicherung abgebrochen!", vbOKOnly + vbExclamation
End If
End Sub

Anzeige
AW: Workbook.open
23.01.2018 14:52:01
Georg
Vielen Dank an alle, es geht jetzt!!!

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige