Datei suchen - Tabellenblatt kopieren

Frage: In meiner Datei habe ich auf einem Tabellenblatt einen Button. Wenn ich da drauf klicke, soll folgendes passieren:

1. Eine InputBox fragt nach einem Dateinamen.
2. Diese wird in einem Ordner (inklusive Unterordner) gesucht.
3. Wenn gefunden, dann geöffnet, sonst MsgBox.
4. Aus der Datei mit dem Button soll dann ein bestimmtes Tabellenblatt in die geöffnete Datei ans Ende kopiert werden und den Namen aus der InputBox erhalten.

Wie geht das?

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, _
    ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
Const strPath As String = "C:\Temp\"
Const strEx As String = ".xlsx"
Sub Test_1()
    Dim strPathName As String * 255
    Dim wkbBook As Workbook
    Dim strSearch As String
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    On Error GoTo Fin
    strSearch = InputBox("Bitte Nr eingeben:", "Datei", "123-456")
    If Trim(strSearch) = "" Then Exit Sub
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    lngTMP = SearchTreeForFile(strPath, strSearch & strEx, strPathName)
    If lngTMP = 0 Then
        MsgBox "Datei nicht vorhanden"
    Else
        strPathName = Left$(strPathName, _
            InStr(1, strPathName, vbNullChar) - 1)
        strName = RTrim(strPathName)
        Set wkbBook = Workbooks.Open(strName)
        With wkbBook
            If fncSheet(.Name, strSearch) = False Then
                ThisWorkbook.Worksheets("Tabelle3").Copy _
                    After:=.Worksheets(.Worksheets.Count)
                .Worksheets(.Worksheets.Count).Name = strSearch
            Else
                MsgBox "Tabellenblatt schon vorhanden!"
            End If
        End With
        wkbBook.Close True
    End If
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    Set wkbBook = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function fncSheet(ByVal strFile As String, _
    ByVal strSheet As String) As Boolean
    Dim objWorksheet As Worksheet
      For Each objWorksheet In Workbooks(strFile).Worksheets
        If objWorksheet.Name = strSheet Then fncSheet = True: Exit For
      Next objWorksheet
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...