AW: Nachtrag
05.11.2007 12:35:00
Chris
Servus,
probiers mal so:
Sub Zeileneinlesen()
Dim oFS As Object, oFLDR As Object, oFILE As Object
Dim lRow As Long
Dim wkbMy As Workbook, wsMy As Worksheet, lngZeile As Long, lngLetzte As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oFS = CreateObject("scripting.filesystemobject")
lRow = 2
Set oFLDR = oFS.getfolder("\\Server04\av\SharePoint_Beschlaglisten")
For Each oFILE In oFLDR.Files
If oFILE Like "*.xls" Or oFILE Like "*.xlsm" Or oFILE Like "*.xlsx" Then
lRow = lRow
Set wkbMy = Workbooks.Open(oFILE)
For Each wsMy In wkbMy.Worksheets
If wsMy.Name Like "BL_*" Then
Dim wsMyZeile As Long, wsMyletzte As Long
wsMyletzte = wsMy.Cells(Rows.Count, 1).End(xlUp).Row
For wsMyZeile = 5 To wsMyletzte
If wsMy.Cells(wsMyZeile, 1) "" Then
wsMy.Range("A" & wsMyZeile & ":B" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 5).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("G" & wsMyZeile & ":N" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 7).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("AA" & wsMyZeile & ":AD" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("AE" & wsMyZeile & ":AF" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 13).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lRow = lRow + 1
End If
Next wsMyZeile
End If
Next
wkbMy.Close False
Kill wkbMy ' Befehl für das löschen der Datei
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Aber erstmal testen, bevor du auf die Ursprungsdateien losgehst.
Gruß
Chris