tabelle/Mappe ersetzen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jürg,
der Code gehört in ein Modul der Mappe, in der sich die zu kopierende Tabelle befindet.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Tabellekopieren()
Dim objWS As Worksheet, objWb As Workbook
Dim strPath As String, n As Integer, i As Integer
Dim a, result As Long

On Error GoTo ErrExit
GMS

strPath = "F:\Temp" 'Verzeichnis das durchsucht werden soll- Anpassen!

result = FileSearchFSO(a, strPath, "*.xls", True)
'Letzter Parameter FALSE, wenn Unterordner nicht durchsucht werden sollen!

If result <> 0 Then
    Set objWS = ThisWorkbook.Sheets("Arbeit")

    For n = 1 To UBound(a)
        Set objWb = Workbooks.Open(a(n))
        If SheetExist("Notiz", objWb.Name) Then
            i = objWb.Sheets("Notiz").Index
            objWb.Sheets("Notiz").Delete
        Else
            i = 1
        End If
        objWS.Copy Before:=objWb.Sheets(i)
        objWb.Close True
    Next

End If

ErrExit:
GMS True
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description
End If
Set objWb = Nothing
Set objWS = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    End If
Next

If SubFolders Then
    For Each mfsoSubFolder In mfsoFolder.SubFolders
        FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
    Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

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 = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Hallo Jürg,
kein Problem.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Tabellekopieren()
Dim objWS As Worksheet, objWb As Workbook
Dim strpath As String, n As Integer
Dim a, result As Long

On Error GoTo ErrExit
GMS

strpath = "F:\Temp" 'Verzeichnis das durchsucht werden soll- Anpassen!

result = FileSearchFSO(a, strpath, "*.xls", True)
'Letzter Parameter FALSE, wenn Unterordner nicht durchsucht werden sollen!

If result <> 0 Then
    Set objWS = ThisWorkbook.Sheets("Arbeit")

    For n = 1 To UBound(a)
        Set objWb = Workbooks.Open(a(n))
        If SheetExist("Notiz", objWb.Name) Then
            objWb.Sheets("Notiz").Delete
        Else
            i = 1
        End If
        objWS.Copy Before:=objWb.Sheets(objWb.Sheets.Count)
        objWb.Close True
    Next

End If

ErrExit:
GMS True
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description
End If
Set objWb = Nothing
Set objWS = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    End If
Next

If SubFolders Then
    For Each mfsoSubFolder In mfsoFolder.SubFolders
        FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
    Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

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 = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

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