Code in Excel schreiben & in VBA-Proj. übernehmen

Sub DATEIENSICHERUNG() Dim myFileSystemObject As Object Set myFileSystemObject = CreateObject("Scripting.FileSystemObject") 'Kopie der einzelnen Dateien von A nach B: myFileSystemObject.CopyFile "F:\A IONENCHROMATOGRAPHIE\BACKUPs\SEQUENZEN IC ZUCKER 2006.cmb", "S:\DATEN\WW\DOKS\REF10\A IONENCHROMATOGRAPHIE\BACKUPs\SEQUENZEN IC ZUCKER 2006.cmb" 'usw. myFileSystemObject.CopyFile "S:\DATEN\WW\DOKS\REF10\A IONENCHROMATOGRAPHIE\IC ZUCKER Backup\IC ZUCKER 15.xls", "F:\A IONENCHROMATOGRAPHIE\IC ZUCKER Backup\IC ZUCKER 15.xls" Set myFileSystemObject = Nothing Workbooks("SICHERUNG DATEIEN.xls").Close SaveChanges:=True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
noch eine komfortable Variante :-)
Die Quell und Zieldateien kann jeder Benutzer frei auswählen, und werden für die weitere Verwendung gespeichert.
Ich hatte das mal für was anderes programmiert und etwas angepasst.
Option Explicit
'(C) Ramses
'Der gesamte Code gehört in ein Modul
'Variablen Deklaration
' Funktion um Einträge aus einer INI Datei zu Lesen
Private Declare Function ReadINIString Lib "kernel32" _
    Alias "GetPrivateProfileStringA" _
    (ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, ByVal lpDefault$, _
    ByVal lpReturnedString$, ByVal nSize As Long, _
    ByVal lpFileName$) As Long

' Funktion, um Einträge in eine INI Datei zu schreiben
Private Declare Function WriteINIString& Lib _
    "kernel32" Alias "WritePrivateProfileStringA" _
    (ByVal AppName$, ByVal KeyName$, _
    ByVal keydefault$, ByVal fileName$)

'************************************************************
'Nur hier in diesem Bereich Änderungen vornehmen
'
'Einstellungen der zuletzt verwendeten Ordner werden hier zwischengespeichert
Private Const INI_File = "c:\LastFolder.ini"
'Dateien die gesichert werden sollen
Private Const BackUpfileName As String = "cbm"
'-------------------------------------------
'
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Ab hier keine Änderungen mehr vornehmen
'Einstellungen der letzten Ordner werden in diesen
'INI-Section's gespeichert
Private Const LastFolder As String = "LastFolder"
'Für variablen Einsatz mit der INI-Datei...
Private Const BaseFolder As String = "BaseFolder"
'****************************************************

Function SaveMyFolder(mysection As String, newFolder As String)
    '1. Zuletzt verwendeten Ordner speichern
    WriteINIString mysection, mysection, newFolder, INI_File
End Function

Function GetMyFolder(mysection As String, LastFolder As String) As String
    Dim tmpRead As String
    'Variablengrösse bestimmen
    '255 Zeichen lang
    tmpRead = String(255, 0)
    ReadINIString mysection, LastFolder, vbNullString, tmpRead, 255, INI_File
    GetMyFolder = Left$(tmpRead, InStr(1, tmpRead, Chr(0)) - 1)
End Function

Sub MoveFiles_for_Backup()
    '(C) Ramses
    'Kopiert alle CBM in einem Ordner
    'in einen Zielordner
    'Die Einstellungen BaseFolder und LastFolder werden in einer INI-Datei gespeichert
    Dim tmpName As String, tarName As String, tarPath As String, srcPath As String
    Dim myFSO As Object, myFld As Object, myFldFiles As Object, myFile As Object
    Dim objFolder As Object, objFolderItem As Object, objShell As Object
    Dim psCount As Integer, dqmCount As Integer, dqmCounter As Integer, psCounter As Integer
    Dim Qe As Integer
    Dim fSearch As FileSearch
    Dim myErr As Integer
    'ErrorHandler starten
    On Error GoTo myErrorHandler
    'Erstellen des FileSystemObjectes
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    'Zielordner auswählen
    NewTargetPath:
    '*****************************
    'Quellordner bestätigen
    If GetMyFolder(BaseFolder, BaseFolder) <> "" And GetMyFolder(LastFolder, LastFolder) <> "" Then
        Qe = MsgBox("Möchten Sie die beiden Ordner: " & vbCrLf & _
            "Quellordner: " & GetMyFolder(BaseFolder, BaseFolder) & vbCrLf & _
            "Zielordner: " & GetMyFolder(LastFolder, LastFolder) & vbCrLf & _
            "weiterverwenden ?", vbQuestion + vbYesNo + vbDefaultButton1, "Ordner bestätigen")
        If Qe = vbNo Then
            'Altes INI_file löschen
            Kill INI_File
            Set objFolder = objShell.BrowseForFolder(0&, "Quell Ordner auswählen...", 0&, GetMyFolder(BaseFolder, BaseFolder))
            If objFolder Is Nothing Then
                Exit Sub
            End If
            Set objFolderItem = objFolder.self
            srcPath = objFolderItem.Path
            If Not myFSO.folderexists(srcPath) Then
                MsgBox "Der Ordner :"" " & srcPath & " "" existiert nicht.", vbCritical + vbOKOnly, "Abbruch"
                Exit Sub
            End If
            'Wenn neuer Quellordner definiert wurde diesen speichern
            If srcPath <> GetMyFolder(BaseFolder, BaseFolder) Then
                SaveMyFolder BaseFolder, srcPath
            End If
            'Zielordner bestätigen
            Set objFolder = objShell.BrowseForFolder(0&, "Ziel Ordner auswählen..." & Chr$(13) & _
                "ABBRECHEN um neuen Zielordner im Basisverzeichnis: """ & srcPath & """ zu erstellen.", 0&, GetMyFolder(LastFolder, LastFolder))
            If objFolder Is Nothing Then
                'Bei Abbrechen !!!! wenn neuer Zielordner im Basisfolder erstellt werden soll !!!
                Qe = MsgBox("Möchten Sie einen neuen Zielordner erstellen ?", vbQuestion + vbYesNo, "Ziel ändern ?")
                If Qe = vbYes Then
                    Set objFolder = objShell.BrowseForFolder(0&, "Ziel Ordner auswählen...", 0&, GetMyFolder(BaseFolder, BaseFolder))
                    If objFolder Is Nothing Then
                        MsgBox "Kein Zielordner ausgewählt", vbCritical + vbOKOnly, "Abbruch"
                        Exit Sub
                    End If
                Else
                    Exit Sub
                End If
            End If
            Set objFolderItem = objFolder.self
            tarPath = objFolderItem.Path
            If Not myFSO.folderexists(tarPath) Then
                MsgBox "Der Ordner :"" " & tarPath & " "" existiert nicht.", vbCritical + vbOKOnly, "Abbruch"
                Exit Sub
            End If
            '*********************************
            If srcPath = tarPath Then
                Qe = MsgBox("Der Quell- und der Zielpfad sind gleich." & Chr$(13) & _
                    "Neuen Ordner auswählen ?", vbCritical + vbYesNo, "Abbruch ?")
                If Qe = vbNo Then
                    Exit Sub
                Else
                    GoTo NewTargetPath
                End If
                '*********************************
                'Wenn neuer Zielordner definiert wurde diesen speichern
                If tarPath <> GetMyFolder(LastFolder, LastFolder) Then
                    SaveMyFolder LastFolder, tarPath
                End If
            End If
        Else
            'Bisherige Einstellungen weiterverwenden
            srcPath = GetMyFolder(BaseFolder, BaseFolder)
            tarPath = GetMyFolder(LastFolder, LastFolder)
        End If
    End If

    'File Search Initialisieren um die Anzahl Dateien zu bestimmen
    Set fSearch = Application.FileSearch
    With fSearch
        'ermitteln der Anzahl von BackUpFilename - Files im Zielordner
        .NewSearch
        .LookIn = tarPath
        .SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
        .FileType = msoFileTypeAllFiles
        .fileName = "*." & BackUpfileName
        .Execute
        dqmCount = .FoundFiles.Count + 1
    End With
    'Copy Schleife starten
    '*****************************
    'Zuweisen des Quellpfades wo die Dateien herkommen
    'Bei Verwendung der Variablen BaseFolder mit variablem Pfad
    Set myFld = myFSO.GetFolder(srcPath)
    '******************************
    'Zuweisung der Dateien in diesem Ordner
    Set myFldFiles = myFld.Files
    For Each myFile In myFldFiles
        tmpName = myFile.Name
        'Das INI File vom Kopiervorgang ausschliessen
        'INI_File ist die globale Variable !!!
        If Right(tmpName, 3) = BackUpfileName Then
            tarName = tarPath & "\" & tmpName & "." & BackUpfileName
            'DQM Zähler hochsetzen
            dqmCounter = dqmCounter + 1
            dqmCount = dqmCount + 1
        End If
        myFSO.copyFile myFile, tarName
        MoveRestart:
    Next
    MsgBox "Es wurden "" " & dqmCounter & " " & BackUpfileName & "-File Dateien Kopiert"
    'Fehlerbehandlung Ende
    myErrorExit:
    Qe = MsgBox("Soll diese Datei: "" " & ThisWorkbook.Name & " "" geschlossen werden ?", vbQuestion + vbYesNo, "Programm Ende")
    If Qe = vbYes Then
        ThisWorkbook.Close SaveChanges:=True
    End If
    Exit Sub

    'Fehlerbehandlung starten
    myErrorHandler:
    Select Case Err
        Case 58
            Qe = MsgBox("Die Datei "" " & myFile & " "" mit dem neuen Namen: "" " & tarName & _
                " "" existiert bereits im Folder " & tarPath & Chr$(13) & _
                "Soll das Makro abgebrochen werden ?" & Chr$(13) & _
                "Bei NEIN wird versucht die restlichen Dateien zu kopieren ?! ", _
                vbCritical + vbYesNoCancel, "Doppelte Datei")
            If Qe = vbYes Then
                MsgBox "Makro wird abgebrochen"
                Resume myErrorExit
                Exit Sub
            End If
            Resume MoveRestart
        Case Else
            MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Unerwarteter Fehler > Abbruch File-Move Action"
            Resume myErrorExit
    End Select
End Sub

Der Code gehört in ein Modul
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Code in Excel schreiben & in VBA-Proj. übernehmen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code in Excel schreiben & in VBA-Proj. übernehmen

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

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread