AW: Arbeitsmappen Öffnen per Schleife
10.12.2009 09:45:47
welga
Hallo Carstma,
sorry dass ich mich nicht gemeldet hatte.
Ich dachte eigentlich daran, nicht die Sheets zu kopieren, sondern ausschließlich deren Inhalt. Somit sollten keine Makros in der abgespeicherten Arbeitsmappe sein.
Versuche mal folgenden Code:
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", "C:\Dokumente und Einstellungen\admin\Desktop\neuer ordner")
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 abgespeichert werden soll.", "Pfad _
definieren", "C:\Dokumente und Einstellungen\admin\Desktop\neuer ordner1")
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
' Ausgewählte Dateien öffnen
For lngCount = 1 To totFiles ' Anzahl der Dateien
Workbooks.Add
varDateiname = .FoundFiles(lngCount)
If varDateiname False Then ' Test auf gültigen Dateinamen
' CSV-Dateien öffnen, Meßwerte lesen und Datei schließen
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)), local:=True
datname = Workbooks(3).Name
speicherpfad1 = speicherpfad & "\" & datname
For n = 1 To Workbooks(3).Sheets.Count
Workbooks(3).Activate
tabname = ActiveWorkbook.Sheets(n).Name
ActiveWorkbook.Sheets(n).Activate
Range(Cells(1, 1), Cells(64000, 100)).Select 'Hier anpassen!!!!!!!!!!!!! _
111
Selection.Copy
Workbooks(2).Activate
Sheets(n).Activate
Cells(1, 1).Activate
Selection.PasteSpecial
ActiveWorkbook.Sheets(n).Name = tabname
Next n
Application.CutCopyMode = False
Windows(datname).Activate
ActiveWindow.Close
Workbooks(2).Activate
Workbooks(2).SaveAs speicherpfad1
Workbooks(2).Close
Application.CutCopyMode = True
End If
Next lngCount
End If
End With
End Sub
Gruß
welga