Sub kopierenOhneMakros()
Const quellPfad = "C:\temp\quelle\"
Const zielPfad = "c:\temp\ziel\"
Const dateiAnf = "LS"
Const dateiEnd = ".xls"
Const dateiNrLaenge = 5
Dim dateiNr As Long
Dim dateiNrString As String
Dim dateiName As String
Dim myWbk As Workbook
Application.ScreenUpdating = False
For dateiNr = 1 To 2000 ' Nr. anpassen, darf mehr sein
dateiNrString = dateiNr
While Len(dateiNrString) < 5
dateiNrString = 0 & dateiNrString
Wend
dateiName = dateiAnf & dateiNrString & dateiEnd
Application.StatusBar = dateiName
If Dir(quellPfad & dateiName) <> "" Then
' Damit keine Makroabfrage kommt
Application.DisplayAlerts = True
' Damit keine Makros ausgeführt werden
Application.EnableEvents = False
' Schreibgeschützt öffnen, ohne LinkUpdates
' dabei Fehlerbehandlung aus
On Error Resume Next
Set myWbk = Workbooks.Open(quellPfad & dateiName, False, True)
On Error GoTo 0
Application.EnableEvents = False
Application.DisplayAlerts = False
' Wenn öffnen geklappt hat
If Not myWbk Is Nothing Then
' Tabellenblätter kopieren
myWbk.Sheets.Copy
' Quellmappe zu
myWbk.Close False
Set myWbk = Nothing
' Im neu entstandenen Workbook noch alle Makros löschen
' (Makros in Tabellenblättern werden mitkopiert)
Call entFerneCode(ActiveWorkbook)
' Speichern - ohne Fehlerbehandlung
' On Error Resume Next
ActiveWorkbook.Close True, zielPfad & dateiName
On Error GoTo 0
End If
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
' Entfernt den Code aus der Arbeitsmappe
Sub entFerneCode(ByRef myWbk As Workbook)
Dim codeObject As Object
For Each codeObject In myWbk.VBProject.VBComponents
With codeObject
' Alle Module (Type 1), Forms (Code 2) und Klassenmodule (Code 3) löschen
If .Type >= 1 And .Type <= 3 Then
myWbk.VBProject.VBComponents.Remove codeObject
ElseIf .Type = 100 Then
' Etwaigen Code in Tabellenblättern und DieseArbeitsmappe löschen
On Error Resume Next
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
On Error GoTo 0
End If
End With
Next
End Sub
Sub kopierenOhneMakros()
Const quellPfad = "C:\temp\quelle\"
Const zielPfad = "c:\temp\ziel\"
Const dateiAnf = "LS"
Const dateiEnd = ".xls"
Const dateiNrLaenge = 5
Dim dateiNr As Long
Dim dateiNrString As String
Dim dateiName As String
Dim myWbk As Workbook
Application.ScreenUpdating = False
For dateiNr = 1 To 2000 ' Nr. anpassen, darf mehr sein
dateiNrString = dateiNr
While Len(dateiNrString) < 5
dateiNrString = 0 & dateiNrString
Wend
dateiName = dateiAnf & dateiNrString & dateiEnd
Application.StatusBar = dateiName
If Dir(quellPfad & dateiName) <> "" Then
' Damit keine Makroabfrage kommt
Application.DisplayAlerts = True
' Damit keine Makros ausgeführt werden
Application.EnableEvents = False
' Schreibgeschützt öffnen, ohne LinkUpdates
' dabei Fehlerbehandlung aus
On Error Resume Next
Set myWbk = Workbooks.Open(quellPfad & dateiName, False, True)
On Error GoTo 0
Application.EnableEvents = True
Application.DisplayAlerts = True
' Wenn öffnen geklappt hat
If Not myWbk Is Nothing Then
' Tabellenblätter kopieren
myWbk.Sheets.Copy
' Quellmappe zu
myWbk.Close False
Set myWbk = Nothing
' Im neu entstandenen Workbook noch alle Makros löschen
' (Makros in Tabellenblättern werden mitkopiert)
Call entFerneCode(ActiveWorkbook)
' Speichern - ohne Fehlerbehandlung
On Error Resume Next
ActiveWorkbook.Close True, zielPfad & dateiName
On Error GoTo 0
End If
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
' Entfernt den Code aus der Arbeitsmappe
Sub entFerneCode(ByRef myWbk As Workbook)
Dim codeObject As Object
For Each codeObject In myWbk.VBProject.VBComponents
With codeObject
' Alle Module (Type 1), Forms (Code 2) und Klassenmodule (Code 3) löschen
If .Type >= 1 And .Type <= 3 Then
myWbk.VBProject.VBComponents.Remove codeObject
ElseIf .Type = 100 Then
' Etwaigen Code in Tabellenblättern und DieseArbeitsmappe löschen
On Error Resume Next
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
On Error GoTo 0
End If
End With
Next
End Sub
Sub kopierenOhneMakros()
Const quellPfad = "C:\temp\quelle\"
Const zielPfad = "c:\temp\ziel\"
Const dateiAnf = "LS"
Const dateiEnd = ".xls"
Const dateiNrLaenge = 5
Dim dateiNr As Long
Dim dateiNrString As String
Dim dateiName As String
Dim myWbk As Workbook
Application.ScreenUpdating = False
For dateiNr = 1 To 2000 ' Nr. anpassen, darf mehr sein
dateiNrString = dateiNr
While Len(dateiNrString) < 5
dateiNrString = 0 & dateiNrString
Wend
dateiName = dateiAnf & dateiNrString & dateiEnd
Application.StatusBar = dateiName
If Dir(quellPfad & dateiName) <> "" Then
' Damit keine Makroabfrage kommt
Application.DisplayAlerts = False
' Damit keine Makros ausgeführt werden
Application.EnableEvents = False
' Schreibgeschützt öffnen, ohne LinkUpdates
' dabei Fehlerbehandlung aus
On Error Resume Next
Set myWbk = Workbooks.Open(quellPfad & dateiName, False, True)
On Error GoTo 0
Application.EnableEvents = True
Application.DisplayAlerts = True
' Wenn öffnen geklappt hat
If Not myWbk Is Nothing Then
' Tabellenblätter kopieren
myWbk.Sheets.Copy
' Quellmappe zu
myWbk.Close False
Set myWbk = Nothing
' Im neu entstandenen Workbook noch alle Makros löschen
' (Makros in Tabellenblättern werden mitkopiert)
Call entFerneCode(ActiveWorkbook)
' Speichern - ohne Fehlerbehandlung
On Error Resume Next
ActiveWorkbook.Close True, zielPfad & dateiName
On Error GoTo 0
End If
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
' Entfernt den Code aus der Arbeitsmappe
Sub entFerneCode(ByRef myWbk As Workbook)
Dim codeObject As Object
For Each codeObject In myWbk.VBProject.VBComponents
With codeObject
' Alle Module (Type 1), Forms (Code 2) und Klassenmodule (Code 3) löschen
If .Type >= 1 And .Type <= 3 Then
myWbk.VBProject.VBComponents.Remove codeObject
ElseIf .Type = 100 Then
' Etwaigen Code in Tabellenblättern und DieseArbeitsmappe löschen
On Error Resume Next
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
On Error GoTo 0
End If
End With
Next
End Sub
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