AW: Excel mit Makro öffnen?
03.02.2022 10:09:35
Andreas
Guten Morgen Peter,
mein Problem damit ist, dass ich in der Tabelle "Planung" leider schon ein ziemlich großes Makro hab.
Ist aber das einzige Blatt, in dem nachher Daten eigegeben werden sollen.
Wie könnte man das lösen, bzw. kannst du mir sagen wie ich beide Makros im Tabellenblatt "Planung" ablegen kann?
Das ist da aktuell drin, mit viel Hilfe von dem 1a Support in diesem Forum : )
'unter Anbindung von Bibliothek "Microsoft Scripting Runtime":
'Extras, Verweise..., Hacken bei "Microsoft Scripting Runtime"
Dim FSO As New FileSystemObject
Dim DateiPfad As String
Const sPfadErledigt As String = "C:\Users\andreas.senger\Desktop\Test neu\"
Const DateinamenMuster = " K xxx.xlsm"
Private Sub CommandButton1_Click()
Dim Datei As File
'1. Prüfen, dass der Pfad gültig ist
'2. Prüfen, ob Dateinumemr gültig ist
'3. Prüfen ob Datei bereit existiert
'4. Daten übertragen
'5. Datein Speichern
'1.
If Pfad_prüfen(sPfadErledigt) Is Nothing Then
MsgBox "Verzeichnis """ & sPfadErledigt & """ nichtvorhadne oder nicht gefunden.", vbExclamation
Exit Sub
End If
'2.
If Worksheets("Planung").Range("AK1").Value = "" Or Not IsNumeric(Worksheets("Planung").Range("AK1").Value) Then
MsgBox "Nummer """ & Worksheets("Planung").Range("AK1").Value & """ ist für diese Datei nicht gültig.", vbExclamation
Exit Sub
End If
'3
DateiPfad = sPfadErledigt & Replace(DateinamenMuster, "xxx", Worksheets("Planung").Range("AK1").Value)
Set Datei = Datei_prüfen(sPfadErledigt & Replace(DateinamenMuster, "xxx", Worksheets("Planung").Range("AK1").Value))
If Not Datei Is Nothing Then
If MsgBox("Datei """ & Datei.ShortPath & """ existiert bereits. " & vbCr & vbCr & "Überschreiben?", vbYesNo + vbQuestion) vbYes Then
Exit Sub
End If
End If
'4.
ThisWorkbook.Worksheets("Planung").Range("BC2:BI2").Copy
Workbooks("Übersicht.xlsx").Worksheets("Übersicht").Range("A99999").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'5.
ThisWorkbook.SaveAs DateiPfad, xlOpenXMLWorkbookMacroEnabled
' ThisWorkbook.Close
End Sub
Function Pfad_prüfen(Pfad As String) As Folder
'gibt einen Folder-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Pfad_prüfen = FSO.GetFolder(Pfad)
End Function
Function Datei_prüfen(Pfad As String) As File
'gibt einen File-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Datei_prüfen = FSO.GetFile(Pfad)
End Function
Gruß und nochmals vielen Dank für deine Hilfe =)
Andreas