IF Clause

  • Thread starter Thread starter juergenkemeter
  • Start date Start date
J

juergenkemeter

Hi,

My code looks into a folder with several xls files and opens each one
of them.
Then it copies a specific range out of a sheet and gatheres it into a
new sheet.

Unfortunately the range changes between the xls files.

It would be necessary to look out for the common header string 'Primary
Sequences', and then select the range (cols B to M) below this, until
the next header 'Derived Sequences' occurs.

If someone knows how to add such a condition to my code, this would be
very helpful!

I have enclosed example files.



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

Sub Test_dateiensuchen_und_daten_extrahieren()

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

colcount = 2
colcount2 = 5

strRange = "B" & colcount & ":M5"

With fs
.LookIn = "M:\Development\GeneSheets_DataExtract_Loop\Gene.File.Lists"
.SearchSubFolders = True 'Unterordner auch durchsuchen
.Filename = "*.xls" 'alle Excel-Dateien
.Execute

For i = 1 To .FoundFiles.count - 1

Workbooks.Open .FoundFiles(i), UpdateLinks:=False 'disable message boxes
bla = ActiveWorkbook.Worksheets("Sequence Data").Range("B6:M9")
ActiveWorkbook.Close savechanges:=False

Range(strRange) = bla
colcount = colcount + 4
colcount2 = colcount2 + 4
strRange = "B" & colcount & ":M" & colcount2
'Range("B2:M5").Formula = bla
Next i

End With


Set fs = Nothing
End Sub

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


Cheers,
Jurgen


+-------------------------------------------------------------------+
|Filename: GeneSheets_DataExtract_Loop.zip |
|Download: http://www.excelforum.com/attachment.php?postid=4197 |
+-------------------------------------------------------------------+
 
In which column(s) do the headers occur? Is there always only one set of
headers per file?

I would use .Find on the column containing the headers to get the relevant
start and end rows

Eg something like (untested):

'#######################
const HEADER_COL as integer=1
Dim lStart as long, lEnd as long


lStart=0:lEnd=0

with ActiveWorkbook.Worksheets("Sequence Data").columns(HEADER_COL)
on error resume next
set lStart = .Find("Primary Sequences").row
set lEnd = .Find("Primary Sequences").row
on error goto 0
end with

if lStart>0 and lEnd>0 then
'....calculate range to copy
end if
'######################

You might have to adjust the parameters to .Find() if you need to locate
cells based on partial content.
Try this out and post back if further questions.

Tim.

"juergenkemeter"
 
Hi!

The headers can be found in column B.
The beginning header is 'Primary Sequences', the end header is 'Derived
Sequences' - as you can see in my enclosed example files.

Here is the code I tried, but I get the following error message:
"Compilation fault: Object necessary", and pointing to the line which
contains
Set lStart = .Find("Primary Sequences").Row



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

Sub Test_dateiensuchen_und_daten_extrahieren()

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

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


colcount = 2
colcount2 = 5

strRange = "B" & colcount & ":M5"

With fs
.LookIn = "C:\Dokumente und Einstellungen\Jürgen\Desktop\Gene.File.Lists"
.SearchSubFolders = True 'Unterordner auch durchsuchen
.Filename = "*.xls" 'alle Excel-Dateien
.Execute

For i = 1 To .FoundFiles.count - 1

Workbooks.Open .FoundFiles(i), UpdateLinks:=False 'disable message boxes

lStart = 0: lEnd = 0

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

If lStart > 0 And lEnd > 0 Then


'....calculate range to copy
End If

bla = ActiveWorkbook.Worksheets("Sequence Data").Range("B" & lStart + 1 & ":M" & lEnd - 1)

ActiveWorkbook.Close savechanges:=False

Range(strRange) = bla
colcount = colcount + 4
colcount2 = colcount2 + 4
strRange = "B" & colcount & ":M" & colcount2
'Range("B2:M5").Formula = bla
Next i

End With


Set fs = Nothing
End Sub
 
Sorry, my error. Remove the "Set" from both those lines.

lStart = .Find("Primary Sequences").Row
lEnd = .Find("Derived Sequences").Row

Tim.

--
Tim Williams
Palo Alto, CA


"juergenkemeter"
 
I removed the two settings.
I also changed the variables lStart and lEnd, as the actual Data range
begins one row after the header, and ends one row before the next
header.

With the following code, I get the error message (translated from
german...):
"Run time error 1004 - Application - or object defined fault" in the
line

bla = ActiveWorkbook.Worksheets("Sequence Data").Range("B" & lStart &
":M" & lEnd)


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

Sub Test_dateiensuchen_und_daten_extrahieren()

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

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


colcount = 2
colcount2 = 5

strRange = "B" & colcount & ":M5"

With fs
.LookIn = "C:\Dokumente und Einstellungen\Jürgen\Desktop\Gene.File.Lists"
.SearchSubFolders = True 'Unterordner auch durchsuchen
.Filename = "*.xls" 'alle Excel-Dateien
.Execute

For i = 1 To .FoundFiles.count - 1

Workbooks.Open .FoundFiles(i), UpdateLinks:=False 'disable message boxes

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 'beginning of Data row range
lEnd = lEnd - 1 'end of Data row range
End If

bla = ActiveWorkbook.Worksheets("Sequence Data").Range("B" & lStart & ":M" & lEnd)

ActiveWorkbook.Close savechanges:=False

Range(strRange) = bla
colcount = colcount + 4
colcount2 = colcount2 + 4
strRange = "B" & colcount & ":M" & colcount2
'Range("B2:M5").Formula = bla
Next i

End With

Set fs = Nothing
End Sub
 
bla = ActiveWorkbook.Worksheets("Sequence Data").Range("B" & lStart &":M"
& lEnd)

What are you trying to do with this line? Right now it's trying to assign a
range *object* to bla (in this case you would need a "Set"), so maybe you
wanted to assign the *value* of the range to bla (giving you a 2-D array of
data in bla)?

The easiest thing to do is just to copy the range *before* closing the file.
Eg:
ActiveWorkbook.Worksheets("Sequence Data").Range("B" & lStart &":M" &
lEnd).copy _
thisworkbook.sheets("destination").Cells(10,3)

You'd have to work out the appropriate values to replace the (10,3).

As a side note you should always qualify your Ranges to include the workbook
Eg: not just
Range("A1")
but
ThisWorkbook.Range("A1")

Tim

--
Tim Williams
Palo Alto, CA


"juergenkemeter"
 
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.File.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
 
Back
Top