Ordner und Datei anlegen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jens,
klar, geht auch.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" _
    (ByVal lpPath As String) As Long

Sub CopySheets()
Dim objWs As Worksheet, objWB As Workbook
Dim strDir As String, strPath As String

On Error GoTo ErrExit
GMS

strDir = "F:\Temp" 'Zielverzeichnis - Anpassen

If Right(strDir, 1) <> "\" Then strDir = strDir & "\"

strDir = strDir & "Auswertung_" & Format(Date, "yyyymmdd") & "\"

For Each objWs In ThisWorkbook.Worksheets
    If objWs.Range("D7") <> "" Then
        strPath = strDir & objWs.Range("D7") & "\" & objWs.Range("D7") & ".xls"

        On Error Resume Next
        Set objWB = Workbooks.Open(strPath)
        On Error GoTo ErrExit

        If MakeSureDirectoryPathExists(strPath) <> 0 Then
            If objWB Is Nothing Then
                objWs.Copy
                ActiveWorkbook.SaveAs strPath
                ActiveWorkbook.Close
            Else
                objWs.Copy after:=objWB.Sheets(objWB.Sheets.Count)
                objWB.Close True
            End If
        End If
    End If
Next

ErrExit:
GMS True
Set objWs = Nothing
Set objWB = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = lngCalc
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Hallo nochmal,
nimm diesen Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" _
    (ByVal lpPath As String) As Long

Sub CopySheets()
Dim objWs As Worksheet, objWB As Workbook
Dim strDir As String, strPath As String

On Error GoTo ErrExit
GMS

strDir = "F:\Temp" 'Zielverzeichnis - Anpassen

If Right(strDir, 1) <> "\" Then strDir = strDir & "\"

strDir = strDir & "Auswertung_" & Format(Date, "yyyymmdd") & "\"

For Each objWs In ThisWorkbook.Worksheets
    If objWs.Range("D7") <> "" Then
        strPath = strDir & objWs.Range("D7") & "\" & objWs.Range("D7") & ".xls"

        If MakeSureDirectoryPathExists(strPath) <> 0 Then
            If Dir(strPath) = "" Then
                objWs.Copy
                ActiveWorkbook.SaveAs strPath
                ActiveWorkbook.Close
            Else
                Set objWB = Workbooks.Open(strPath)
                objWs.Copy after:=objWB.Sheets(objWB.Sheets.Count)
                objWB.Close True
            End If
        End If
    End If
Next

ErrExit:
GMS True
Set objWs = Nothing
Set objWB = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = lngCalc
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread