Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Sheets aus verschiedenen Excel-Dateien importieren





Frage

Hallo! Ich möchte aus verschiedenen Excel-Dateien das jeweils erste Sheet in [i] eine[/i] feste, geöffnete Excel-Datei kopieren. Aus welchen Dateien importiert werden soll, soll bei Click auf einen Button (der sich in dem ersten Sheet der Datei, in die importiert wird befindet) über einen "Dateiauswahl"-Dialog geschehen. Die zu importierenden Dateien stehen alle in einem Ordner. Toll wäre es, wenn die Formatierung der importierten Sheets erhalten bliebe. Danke schonmal für evtl. Vorschläge!:) Grüße, Fino

Antwort 1 von piano

hallo
Hier ein Makro dazu:
  Const MappenName = "ImportMehrereMappen.xls"
Const Verz = "C:Eigene Dateien"
Const AuswahlRange = "$A$5"
Private Sub Workbook_Open()
x = DateienAuflisten()
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim MName, i, Anz
If ActiveWorkbook.Name = MappenName Then
If ActiveSheet.Name = Sheets(1).Name Then
    If ActiveCell.Address = AuswahlRange Then
        Anz = ActiveWorkbook.Sheets.Count
        MName = ActiveCell.Value
        ´ActiveCell.Offset(1, 0).Activate
        ´ActiveCell.Select
        ChDir Verz
        On Error Resume Next
        Workbooks.Open MName
        Workbooks(MName).Activate
        ActiveWorkbook.Sheets(1).Select
        ActiveWorkbook.Sheets(1).Copy After:=Workbooks("ImportMehrereMappen.xls").Sheets(Anz)
        ActiveWorkbook.Sheets(Anz + 1).Name = "Import" & Anz
        Workbooks(MappenName).Activate
        ActiveWorkbook.Sheets(1).Select
        Workbooks(MName).Close
    End If
End If
End If
End Sub

Function DateienAuflisten()
Dim i  As Long, DName
´Dim Dateien As String
´Const Verz = "C:Eigene Dateien"
On Error GoTo fehler
ChDir Verz
Sheets(1).Activate
Range("IV1").Select
With Application.FileSearch
    .NewSearch
    .LookIn = Verz
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .Execute
    For i = 1 To .FoundFiles.Count
        ´Dateien = Dateien & .FoundFiles(i) & ";"
        DName = .FoundFiles(i)
        z = InStr(1, DName, ":")
        If z <> 0 Then
            DName = Right(DName, (Len(DName) - z)) ´Laufwerk eliminieren
        End If
        Do While InStr(1, DName, "") <> 0
            z = InStr(1, DName, "")
            DName = Right(DName, (Len(DName) - z)) ´Pfad eliminieren
        Loop
        ´ActiveCell.Value = DName
        ´ActiveCell.Offset(1, 0).Select
    Next i
End With
Range("a5").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$IV$1:$IV$" & i
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "Excel-Dateien in Verzeichnis"
        .ErrorTitle = ""
        .InputMessage = "Wählen Sie eine Mappe aus"
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
GoTo exex:
fehler:
MsgBox "Es gibt kein Verzeichnis mit dem Namen " & Verz
exex:
End Function
 

Beim Öffnen der Mappe wird eine Liste aller Dateien des Verzeichnisses in der letzten Spalte gebildet. Diese wird für die Gültigkeitsprüfung in Zelle A5
verwendet. Bei Wahl einer Mappe wird die 1.Tabelle hinter die letzte Tabelle der Master-Mappe mit Name Importx kopiert.
In VBA-Umgebung Diese Arbaitsmappe doppelklicken und hier den Code eingeben( Konstanten richtigstellen) .
Alle unnötigen Tabellen löschen und Speichern.

Gruß piano

Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.

Antwort 2 von Fino

Was ein Formelwust*g*...ich bin beeindruckt!

Ich bekomme aber leider immer die Fehlermeldung: "Es gibt kein Verzeichnis mit dem Namen " & Verz"...

Grüße,
Fino

Antwort 3 von piano

Hallo
halb so schlimm.
Wie lautet der Pfad und wie hast Du die Konstanten angepasst?
Ev. sende mir Deine Mappe an piano1244@hotmail.com

Antwort 4 von piano

Hallo
Aus irgendwelchen Gründen sind einige Zeilen aus der For-Schleife verstümmelt angekommen:
Do While InStr(1, DName, "") <> 0
z = InStr(1, DName, "")
DName = Right(DName, (Len(DName) - z)) ´Pfad eliminieren
Loop
ActiveCell.Value = DName
ActiveCell.Offset(1, 0).Select

ausserdem sind die Kommentarzeilen (´) mit dem einfachen Hochkomma zu versehen (Fehler von Supportnet).
Gruss piano

Antwort 5 von piano

Hallo
wie ich soeben bemerke , hat es wieder einen Übertragungsfehler gegeben:
2 mal DName, ""
Zwischen die beiden Apostrophe gehört ein " Backslash" - dieser wird offensichtlich auch von Supportnet eliminiert !!!