Hi Tim,

the following code works now, thanks for your help.
Right now, I am working on how to remove all blank rows in the
Destination Sheet, and shift the next row up.


Code:
--------------------

Sub Test_noSpaces_dateiensuchen_und_daten_extrahieren( )

Dim fs As Variant, i As Integer, bla
Dim strRange As String, colcount As Integer, colcount2 As Integer
Dim cl As Range
Set fs = Application.FileSearch

Const HEADER_COL As Integer = 2
Dim lStart As Long, lEnd As Long



With fs
.LookIn = "M:\Development\GeneSheets_DataExtract_Loop\Gene.F ile.Lists"
.SearchSubFolders = True
.Filename = "*.xls"
.Execute

For i = 1 To .FoundFiles.count - 1

Workbooks.Open .FoundFiles(i), UpdateLinks:=False 'disable update messages

lStart = 0: lEnd = 0

With ActiveWorkbook.Worksheets("Sequence Data").Columns(HEADER_COL)
On Error Resume Next
lStart = .Find("Primary Sequences").Row
lEnd = .Find("Derived Sequences").Row
On Error GoTo 0
End With

If lStart 0 And lEnd 0 Then
lStart = lStart + 1 'start row of Data range
lEnd = lEnd - 1 'end row of Data range
End If

ActiveWorkbook.Worksheets("Sequence Data").Range("B" & lStart & ":M" & lEnd).Copy
ActiveWorkbook.Close savechanges:=False


ActiveSheet.Range("b65536").End(xlUp).Offset(1, 0).Select 'goto next empty cell
ActiveSheet.Paste

Next i

End With


Dim cRows As Long
Dim u As Long

cRows = Cells(Rows.count, "A").End(xlUp).Row
For u = cRows To 1 Step -1
If Cells(i, "A").Value = "" Then
Range("B" & u, "M" & u).Delete shift:=xlUp
End If
Next
'Cells.Select
'Range("A800:A2400").SpecialCells(xlCellTypeBlanks ).EntireRow.Delete
'Range("B2:M65000").SpecialCells(xlCellTypeBlanks) .EntireRow.Delete




Set fs = Nothing
End Sub

--------------------


Cheers
Juergen


--
juergenkemeter
------------------------------------------------------------------------
juergenkemeter's Profile: http://www.excelforum.com/member.php...o&userid=25248
View this thread: http://www.excelforum.com/showthread...hreadid=499619