Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
920to924
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
920to924
920to924
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zeilen finden und kopieren

Zeilen finden und kopieren
31.10.2007 06:59:00
volker
Hai Leute,
ich möcht mit meinem makro in allen Sheets mit Namen "BL_*" ab Zeile 4 alle beschriebenen Zeilen kopieren und in der aktuellen einfügen.
hab ich mit folgendem makro versucht, hängt aber bei ElseIf (Laufzeitfehler 1004)
Hoffe Ihr könnt mir helfen, Danke Gruss volker

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" Then
lRow = lRow
Set wkbMy = Workbooks.Open(oFILE)
For Each wsMy In wkbMy.Worksheets
If wsMy.Name Like "BL_*" Then
lngZeile = 4
lngLetzte = Cells(65536, 1).End(xlUp).Row
ElseIf Cells(lngZeile, 4).Value > 0 Then Range(lngZeile & ":" & lngZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lRow = lRow + 1
End If
Next
wkbMy.Close False
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeilen finden und kopieren
31.10.2007 19:27:16
Herbert
Hi,

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" Then
lRow = lRow
Set wkbMy = Workbooks.Open(oFILE)
For Each wsMy In wkbMy.Worksheets
If wsMy.Name Like "BL_*" Then
lngZeile = 4
lngLetzte = Cells(wsMy.Rows.Count, 1).End(xlUp).Row
If Cells(lngZeile, 4).Value > 0 Then
Range(lngZeile & ":" & lngZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lRow = lRow + 1
End If
End If
Next
wkbMy.Close False
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


mfg Herbert

Anzeige
Danke!
02.11.2007 07:15:56
volker
Danke für dei Mühe, ich bau es ein.
Viele Grüsse volker

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige