Bestimmtes Tabellenblatt in verschiedene Dateien k

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter,
der Code gehört in die Datei "Data_neu.xls".
Teste den Code zuerst an einigen Kopien der Dateien!
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub replaceSheet()
    Dim objWSNew As Worksheet, objWS As Worksheet
    Dim objWB As Workbook
    Dim strPath As String, strFile As String
    Dim intIndex As Integer

    On Error GoTo ErrExit
    GMS

    Set objWSNew = ThisWorkbook.Sheets("Data")

    strPath = "C:\dcf"

    strFile = Dir(strPath & "*.xls")

    Do While strFile <> ""
        If strFile <> ThisWorkbook.FullName Then
            Set objWB = Workbooks.Open(strFile)

            For Each objWS In objWB.Worksheets
                If objWS.Name = "Data" Then
                    intIndex = objWS.Index
                    objWS.Delete
                    objWSNew.Copy before:=objWB.Sheets(intIndex)
                End If
            Next

            objWB.Close True

        End If

        strFile = Dir
    Loop

    ErrExit:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & _
        Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWB = Nothing
    Set objWS = Nothing
    Set objWSNew = Nothing
End Sub

Private 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 Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With

End Sub

Gruß Sepp

Hallo Peter,
da war noch ein "Patzer" drin, jetzt sollte es laufen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub replaceSheet()
    Dim objWSNew As Worksheet, objWS As Worksheet
    Dim objWB As Workbook
    Dim strPath As String, strFile As String
    Dim intIndex As Integer

    On Error GoTo ErrExit
    GMS

    Set objWSNew = ThisWorkbook.Sheets("Data")

    strPath = "C:\dcf"

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

    strFile = Dir(strPath & "*.xls")

    Do While strFile <> ""
        If strFile <> ThisWorkbook.FullName Then
            Set objWB = Workbooks.Open(strPath & strFile)

            For Each objWS In objWB.Worksheets
                If objWS.Name = "Data" Then
                    intIndex = objWS.Index
                    objWS.Delete
                    objWSNew.Copy before:=objWB.Sheets(intIndex)
                End If
            Next

            objWB.Close True

        End If

        strFile = Dir
    Loop

    ErrExit:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & _
        Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWB = Nothing
    Set objWS = Nothing
    Set objWSNew = Nothing
End Sub

Private 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 Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Bestimmtes Tabellenblatt in verschiedene Dateien k

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread