Zellen kopieren makro läuft nicht
30.10.2007 14:36:00
volker
ich möchte mit folgendem makro Daten Tabellen kopieren.
Zuerst ist der Auswahlordner gewählt.
Darin alle *.xls (Frage wie kann ich hier noch einen weitere Dateiendung hinzuschreiben? so? , "*.xlsm"
Die in Frage kommenden Workbooks haben sheets mit Namen BL_*
aus diesen Tabellen raus möcht ich Daten kopieren.
Aber ich bekomm es nicht hin.
Hier mein Code (geht irgendwie durch die 2x For nicht) Danke für Hilfe Gruss volker
Sub Zeileneinlesen()
Dim oFS As Object, oFLDR As Object, oFILE As Object
Dim lRow As Long
Dim wsMy As Worksheet, lngZeile As Long, lngLetzte As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oFS = CreateObject("scripting.filesystemobject")
lRow = 3
Set oFLDR = oFS.getfolder("\\Server04\av\SharePoint_Beschlaglisten")
For Each oFILE In oFLDR.Files
If oFILE Like "*.xls" Then
lRow = lRow
Workbooks.Open oFILE
End If
For Each wsMy In Worksheets
If wsMy.Name Like "BL_*" Then
wsMy.Activate
ActiveSheet.Range("2:2").Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False
lRow = lRow + Range("2:2").Rows.Count
Next
End If
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Next
End Sub