Auswahl_Filtern_Übertrag

Sub TT_Projects_Import() Dim Ziel As Workbook Set Ziel = ThisWorkbook 'für Excel Zwischenspeicherung Application.Dialogs(xlDialogOpen).Show 'öffne Quelldatei Worksheets(1).Range("2:65535").Copy 'kopiere alles zur Zieldatei Ziel.Worksheets(1).Activate 'wechselt zur Zieldatei zurück Ziel.Worksheets(1).Range("2:65535").PasteSpecial _ Paste:=xlPasteValues Application.CutCopyMode = False 'setzt Zwischenablage in Datei ein Worksheets(1).Cells(1, 1).Select 'zeigt Zieldatei wieder an End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub TT_Projects_Import() Dim Ziel As Workbook Set Ziel = ThisWorkbook 'für Excel Zwischenspeicherung Application.Dialogs(xlDialogOpen).Show 'öffne Quelldatei Worksheets(1).UsedRange.Copy 'kopiere alles zur Zieldatei Ziel.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial _ Paste:=xlPasteValues Application.CutCopyMode = False 'setzt Zwischenablage in Datei ein Application.Goto Ziel.Worksheets(1).Cells(1, 1) 'zeigt Zieldatei wieder an End Sub

Hallo,
Es werden jedoch nicht die Daten die in den einzelnen Tabellen in Spalte A mit einer "1" gekennzeichnet sind übertragen.
davon stand auch in deinem Code nichts.
dann kopiert er die erste zeile (A1:J1) der Zieldatei nochmals in die zweite zeile A2:J2
Das passiert, weil du bei Klick auf Abbrechen nicht abbrichst.
Die Tabellen (Test1, Test2, Test3 und Test4) bleiben geöffnet.
weil du sie nicht schließt.
Vielleich ist das ja besser.

Sub TT_Projects_Import()
Dim Ziel As Workbook, sFile As String, wkb As Workbook
Dim i As Integer, arrFiles
Set Ziel = ThisWorkbook 'für Excel Zwischenspeicherung
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
If .Show = -1 Then
For i = 1 To .SelectedItems.Count 'gewählte Dateiname lesen
sFile = sFile & "_" & .SelectedItems(i)
Next
End If
End With
If sFile  "" Then 'es wurden Dateien gewählt
Application.Screenupdating = False
arrFiles = Split(sFile, "_")  'Dateinamen in Array
For i = 1 To UBound(arrFiles) 'Array abarbeiten
Set wkb = Workbooks.Open(arrFiles(i))   'Workbook öffnen
wkb.Sheets(1).Range("A1").CurrentRegion.Offset(1).Copy  'Daten ohne Überschrift kopieren
Ziel.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValues
Application.CutCopyMode = False 'setzt Zwischenablage in Datei ein
wkb.Close False
Next i
End If
Application.Goto Ziel.Worksheets(1).Cells(1, 1) 'zeigt Zieldatei wieder an
End Sub

Das mit der 1 in A fehlt noch.
Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread