AW: Kopieren per Makro - Datei auswählen?
13.02.2010 07:43:02
welga
Hallo Fabio,
versuch mal folgendes:
Sub test()
Dim lngCount As Integer
Dim varDateiname As Variant
Dim n As Integer
Dim Suchpfad As String, Dateiform As String, speicherpfad As String, speicherpfad1 As _
String, tabname As String, datname As String
Dim totFiles As Long
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad _
definieren", "g:\sportverein\jugendfussball")
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Bitte die Endung der Dateiform definieren", "Dateierweiterung", "xls") _
If Dateiform = "" Then Exit Sub
speicherpfad = InputBox("Geben Sie den Ordner an, in den die abgespeicherten Dateien _
abgespeichert werden soll.", "Pfad definieren", "g:\sportverein\jugendfussball-abgearbeitet")
If speicherpfad = "" Then Exit Sub
With Application.FileSearch
.LookIn = Suchpfad
.SearchSubFolders = True
.Filename = "." & Dateiform
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
' Bildschirmaktualisierung deaktivieren
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For n = 1 To ThisWorkbook.Sheets.Count
ThisWorkbook.Sheets(n).UsedRange.Select
Selection.ClearContents
Next n
' Ausgewählte Dateien öffnen
For lngCount = 1 To totFiles ' Anzahl der Dateien
varDateiname = .FoundFiles(lngCount)
If varDateiname False Then ' Test auf gültigen Dateinamen
Workbooks.OpenText Filename:=varDateiname, Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True, _
_
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
_
Array(2, 1))
datname = Workbooks(2).Name
speicherpfad1 = speicherpfad & "\" & datname
For n = 1 To Workbooks(2).Sheets.Count
Workbooks(2).Activate
With ActiveWorkbook.Sheets(n)
tabname = .Name
.Activate
.Range(Cells(1, 1), Cells(.UsedRange.Rows.Count, .UsedRange.Columns. _
Count)).Select 'Hier anpassen!!!!!!!!!
End With
Selection.Copy
With Workbooks(1)
.Activate
Do Until .Sheets.Count = n
If .Sheets.Count n Then .Sheets(n + 1).Delete
Loop
.Sheets(n).Activate
.Sheets(n).Cells(1, 1).Select
Selection.PasteSpecial
.Sheets(n).Name = datname & "-" & tabname
End With
Next n
Windows(datname).Activate
ActiveWorkbook.SaveAs speicherpfad1
Windows(datname).Close
Kill (varDateiname)
End If
Next lngCount
End If
End With
End Sub
Wenn du mir noch sagst, was im Tabellenbaltt Rechner geschehen soll, oder du eine Beispielmappe hochlädst, kann an auch alles automatisieren.
Aktuell werden alle ausgewählten Dateien mit entsprechendem Dateityp ausgelesen , in die aktuelle Mappe Kopiert und die ursprungsdatei in einem anderen Ordner abgespeichert.
Vielleicht hilft esja.
Gruß
welga