Suche ein Makro

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Suche ein Makro
von: Michael
Geschrieben am: 23.07.2015 21:54:07

Hallo Forum
Hätte mal eine Frage ist es möglich ein Makro zu erstellen welches ein Tabelleblatt nennen wir es mal "Vorlage" per Button in einen Vorgesehenen Ordner zu Speichern.
Es soll folgendermaßen gespeichert werden.
Muss am Tag mehrere solcher "Vorlagen" ausfüllen.
In Zelle E5 steht eine Nummer etwa so"00707-123" und in Zelle B35 das Datum.
Jetzt soll das Tabellenblatt"Vorlage" per Button Kopiert und in einem Ordner auf Laufwerk C gespeichert werden. In Laufwerk C ist ein Ordner Protokolle und in dem sind dann lauter Ordner mit verschiedenen Nummern"00707-123" oder "00707-659" .
Es soll also in dem Ordner mit der Nummer die in Zelle E5 steht unter dem Datum das in Zelle B35 steht abgespeichert werden.
Ich hoffe ihr könnt mir da weiter helfen
Gruß Michl

Bild

Betrifft: AW: Suche ein Makro
von: Sepp
Geschrieben am: 23.07.2015 21:57:37
Hallo Michl,
und der Dateiname besteht nur aus dem Datum?
Wenn das Makro für den selben Ordner ein zweites Mal ausgeführt wird, soll die erste Datei überschrieben werden?
In welchem Format soll die Datei gespeichert werden?
Wenn der Ordner nicht existiert, was soll dann geschehen?

Gruß Sepp


Bild

Betrifft: AW: Suche ein Makro
von: Michael
Geschrieben am: 23.07.2015 22:04:19
Hallo
und danke für die schnelle Antwort ich gebe am Tag die Nummer nie doppelt ein also immer eine Andere und die Ordner sind alle schon vorhanden. Die Datei soll nicht ersetzt werden Sonden immer als neue hinzu da ich die Nummer ja nur einmal am Tag habe. Soll als Daten Sicherung für spätere Fragen dienen wann was an welchem Datum war.
Datei soll als Exel Datei gespeichert werden.
Gruß Michael

Bild

Betrifft: AW: Suche ein Makro
von: Sepp
Geschrieben am: 23.07.2015 22:14:34
Hallo Michl,
gut, aber trotzdem mit Sicherung.
In ein allgemeines Modul.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

#If Win64 Then
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As LongLong
#Else
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If

Sub saveTemplate()
  Dim strFile As String, strFolder As String, strRoot As String
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlManual
    .DisplayAlerts = False
  End With
  
  strRoot = "C:\Protokolle"
  
  If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"
  
  With Sheets("Tabelle1") 'Tabellenname anpassen!
    strFolder = strRoot & .Range("E5").Text & "\"
    
    If Not FolderExists(strFolder) Then
      MakeSureDirectoryPathExists strFolder
    End If
    
    strFile = Format(.Range("B35"), "yyyyMMdd") & ".xlsx"
    If FileExists(strFolder & strFile) Then
      MsgBox "Die Datei '" & strFolder & strFile & "' ist schon vorhanden!", vbExclamation
    Else
      .Copy
      ActiveWorkbook.SaveAs strFolder & strFile, xlWorkbookNormal
      ActiveWorkbook.Close True
    End If
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'saveTemplate'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Prozedur - saveTemplate"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlAutomatic
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
End Sub


Private Function FolderExists(FolderName As String) As Boolean
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  FolderExists = objFSO.FolderExists(FolderName)
  Set objFSO = Nothing
End Function


Private Function FileExists(FileName As String) As Boolean
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  FileExists = objFSO.FileExists(FileName)
  Set objFSO = Nothing
End Function


Gruß Sepp


Bild

Betrifft: AW: Suche ein Makro
von: Michael
Geschrieben am: 23.07.2015 22:18:45
Oh super
Das ging ja total fix werde es morgen mal ausprobieren und mich dann sofort melden.
Vielen Dank Sepp

Bild

Betrifft: AW: Suche ein Makro
von: Michael
Geschrieben am: 24.07.2015 06:51:22
Hallo
Guten Morgen Sepp
Hab es Probiert und funktioniert soweit super speichert so wie er soll nur hab ich jetzt das Problem wenn ich die gespeicherte Datei öffnen will bringt er folgenden Meldung.
" die Datei 20150724. xlsm' kann nicht geöffnet werden, da das Dateiformat oder die Dateiweiterung ungü ist. Überprüfen Sie ob die Datei beschädigt ist.
Das Firmat ist xlsm der Datei ". Vorlage" hatte ich gestern vergessen.
Sorry
Gruß Michael

Bild

Betrifft: AW: Suche ein Makro
von: Sepp
Geschrieben am: 24.07.2015 18:53:05
Hallo Michael,
so sollte es klappen.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

#If Win64 Then
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As LongLong
#Else
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If

Sub saveTemplate()
  Dim strFile As String, strFolder As String, strRoot As String
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlManual
    .DisplayAlerts = False
  End With
  
  strRoot = "C:\Protokolle"
  
  If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"
  
  With Sheets("Tabelle1") 'Tabellenname anpassen!
    strFolder = strRoot & .Range("E5").Text & "\"
    
    MakeSureDirectoryPathExists strFolder
    
    
    strFile = Format(.Range("B35"), "yyyyMMdd") & ".xlsx"
    If FileExists(strFolder & strFile) Then
      MsgBox "Die Datei '" & strFolder & strFile & "' ist schon vorhanden!", vbExclamation
    Else
      .Copy
      ActiveWorkbook.SaveAs strFolder & strFile, xlOpenXMLWorkbook
      ActiveWorkbook.Close True
    End If
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'saveTemplate'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Prozedur - saveTemplate"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlAutomatic
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
End Sub


Private Function FileExists(FileName As String) As Boolean
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  FileExists = objFSO.FileExists(FileName)
  Set objFSO = Nothing
End Function


Gruß Sepp


Bild

Betrifft: AW: Suche ein Makro
von: Michael
Geschrieben am: 24.07.2015 21:12:08
Hallo Sepp
Danke ich werde es am Montag gleich mal Testen und Dir Bescheid geben ob es Klapp.
Vielen Dank schonmal
Gruß Michael

Bild

Betrifft: AW: Suche ein Makro
von: Michael
Geschrieben am: 27.07.2015 13:17:26
Hallo Sepp
Danke Makro läuft super ihr seid die besten.
Gruß Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Datenverknüpfung auf Pivot Tabelle"