ijswalker
01-13-2006, 07:49 AM
I am trying to return a variable ranges instead of a fixed range from my workbooks. For example. Workbook 1 can have Range A2:BB12 as shown in the code below and the next workbook can have range A2:BB5 and so on.
Is there a way to change the code to relect the different ranges without hard coding each range in turn?
Hope someome can help?
Thanks
Ian
Public Sub GetDirXlsContents()
' Source sheet name, Source directory path, Source cell Range
Call CopyFromEachFileInPath("DataBase", "C:\Documents and Settings\iwalker\My Documents\Capital Budget 2007\Project Manager", "A2:BB12")
End Sub
Private Sub CopyFromEachFileInPath(SheetName, Path, Rng)
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Path & "\")
Set fc = f.Files
' make a temp sheet
Application.ScreenUpdating = False
TargSh = ActiveSheet.Name
Sheets.Add
TempSh = ActiveSheet.Name
Sheets(TargSh).Activate
Application.ScreenUpdating = True
For Each f1 In fc
With Sheets(TempSh)
' clear temp sheet and start again
.Cells.ClearContents
' Place Src Info on Temp Targ Sheet
If Right(f1.Name, 3) = "xls" Then
fName = Left(f1.Name, Len(f1.Name) - 4)
.Range(Rng).FormulaArray = "='" & Path & "\[" & fName & "]" & SheetName & "'!" & Rng
.Range(Rng).Value = .Range(Rng).Value
'GetValuesFromAClosedWorkbook Path, f1.Name, SheetName, "A1:bb12"
End If
' if columD = 1 copy over
For Each A In .Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
NxRw = Cells(65536, 1).End(xlUp).Row + 1
If Not A.Value = 0 And A.Offset(1, 0).Value = 0 Then ' copy to final sheet
Range("A" & NxRw & ":BB" & NxRw).Value = .Range("A" & A.Row & ":BZ" & A.Row).Value
Range("AS" & NxRw).Value = fName
End If
Next A
End With
' have use:banghead: r see list build, so know not frozen
Cells(NxRw, 1).Select
Next ' workbook
' get rid of temp sheet
Application.DisplayAlerts = False
Sheets(TempSh).Delete
Application.DisplayAlerts = True
End Sub
Is there a way to change the code to relect the different ranges without hard coding each range in turn?
Hope someome can help?
Thanks
Ian
Public Sub GetDirXlsContents()
' Source sheet name, Source directory path, Source cell Range
Call CopyFromEachFileInPath("DataBase", "C:\Documents and Settings\iwalker\My Documents\Capital Budget 2007\Project Manager", "A2:BB12")
End Sub
Private Sub CopyFromEachFileInPath(SheetName, Path, Rng)
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Path & "\")
Set fc = f.Files
' make a temp sheet
Application.ScreenUpdating = False
TargSh = ActiveSheet.Name
Sheets.Add
TempSh = ActiveSheet.Name
Sheets(TargSh).Activate
Application.ScreenUpdating = True
For Each f1 In fc
With Sheets(TempSh)
' clear temp sheet and start again
.Cells.ClearContents
' Place Src Info on Temp Targ Sheet
If Right(f1.Name, 3) = "xls" Then
fName = Left(f1.Name, Len(f1.Name) - 4)
.Range(Rng).FormulaArray = "='" & Path & "\[" & fName & "]" & SheetName & "'!" & Rng
.Range(Rng).Value = .Range(Rng).Value
'GetValuesFromAClosedWorkbook Path, f1.Name, SheetName, "A1:bb12"
End If
' if columD = 1 copy over
For Each A In .Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
NxRw = Cells(65536, 1).End(xlUp).Row + 1
If Not A.Value = 0 And A.Offset(1, 0).Value = 0 Then ' copy to final sheet
Range("A" & NxRw & ":BB" & NxRw).Value = .Range("A" & A.Row & ":BZ" & A.Row).Value
Range("AS" & NxRw).Value = fName
End If
Next A
End With
' have use:banghead: r see list build, so know not frozen
Cells(NxRw, 1).Select
Next ' workbook
' get rid of temp sheet
Application.DisplayAlerts = False
Sheets(TempSh).Delete
Application.DisplayAlerts = True
End Sub