blairt
11-12-2008, 04:21 PM
Hi all,
I am trying to extract information from a sheet in several closed workbooks. The purpose is to summarise a bunch of financial forecasts into one document.
I wrote a program which works, using some info from the KBase. The method involved writing cell information which referenced the closed workbook cell required. But it does it cell by cell.
I need to summarise info from approx 150 cells from 100 workbooks and at the moment, it appears as though each cell reference queries the workbook, and the same workbook will be queried for cell info 150 times before moving on to the next workbook.
I would imagine that it would be alot faster to get all the information required from the workbook with 1 query then move on to the next workbook and do the same. At the moment, the ~150 queries takes about 1 min 10 secs, so for 100 workbooks, will take around 2 hours, thats with the files on a local drive, it is to be used with remote files once complete.
So I am wondering if anyone can tell me a better way? Perhaps using a SQL type query? I am not tip top with SQL so I am not sure if it can solve my problem, if so, i will move my questions to the SQL section, let me know.
Anyway, here is the code:
Sub AlternateSummarise()
'this function summarises all the data
Dim Sws As Worksheet
Dim Lws As Worksheet
Dim Sr As Long, Sc As Long, Lr As Long, Lc As Long
Dim NoFiles As Long
Dim MyCell As Range
Dim Hold As String
Dim Err As Long
Err = 1
Worksheets("Errors").UsedRange.Clear
Call ClearTable
Set Sws = Worksheets("Testing")
Set Lws = Worksheets("All Files")
Sws.Cells(1, 17) = Now()
NoCells = Lws.Cells(1, 4)
Lr = 1
Lc = 3
On Error GoTo ErrorHandling:
'First Column
For Lr = 1 To NoCells
Sws.Cells(6, 17) = Lr / NoCells
For Sr = 14 To 28
For Sc = 13 To 13
If ((Sr - 12) Mod 3 = 0) Then
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
End If
Next Sc
Next Sr
'Main Block 1 Data
For Sr = 14 To 28
For Sc = 14 To 29
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
'Main Block 2 Data
For Sr = 34 To 36
For Sc = 14 To 22
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
'Main Block 3 Data
For Sr = 38 To 40
For Sc = 14 To 18
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
'Bottom Right Side Block Data
For Sr = 37 To 39
For Sc = 21 To 21
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
Next Lr
Sws.Cells(2, 17) = Now()
Exit Sub
ErrorHandling:
Worksheets("Errors").Cells(Err, 1) = Now()
Worksheets("Errors").Cells(Err, 2) = Lws.Cells(Lr, Lc - 2)
Worksheets("Errors").Cells(Err, 3) = Lws.Cells(Lr, Lc - 1)
Worksheets("Errors").Cells(Err, 4) = MyCell.Address
Worksheets("Errors").Cells(Err, 5) = Worksheets("Testing").Cells(1, 1)
Worksheets("Testing").Cells(1, 1) = 0
Err = Err + 1
Resume Next
End Sub
I do realise there is a fair bit of repeated code there and it can be streamlined at least visually, but I am kind of a VBA hack at the moment, so be kind...
Any advice on reducing the run time of the macro would be appreciated.
Thanks in advance
Tim.
I am trying to extract information from a sheet in several closed workbooks. The purpose is to summarise a bunch of financial forecasts into one document.
I wrote a program which works, using some info from the KBase. The method involved writing cell information which referenced the closed workbook cell required. But it does it cell by cell.
I need to summarise info from approx 150 cells from 100 workbooks and at the moment, it appears as though each cell reference queries the workbook, and the same workbook will be queried for cell info 150 times before moving on to the next workbook.
I would imagine that it would be alot faster to get all the information required from the workbook with 1 query then move on to the next workbook and do the same. At the moment, the ~150 queries takes about 1 min 10 secs, so for 100 workbooks, will take around 2 hours, thats with the files on a local drive, it is to be used with remote files once complete.
So I am wondering if anyone can tell me a better way? Perhaps using a SQL type query? I am not tip top with SQL so I am not sure if it can solve my problem, if so, i will move my questions to the SQL section, let me know.
Anyway, here is the code:
Sub AlternateSummarise()
'this function summarises all the data
Dim Sws As Worksheet
Dim Lws As Worksheet
Dim Sr As Long, Sc As Long, Lr As Long, Lc As Long
Dim NoFiles As Long
Dim MyCell As Range
Dim Hold As String
Dim Err As Long
Err = 1
Worksheets("Errors").UsedRange.Clear
Call ClearTable
Set Sws = Worksheets("Testing")
Set Lws = Worksheets("All Files")
Sws.Cells(1, 17) = Now()
NoCells = Lws.Cells(1, 4)
Lr = 1
Lc = 3
On Error GoTo ErrorHandling:
'First Column
For Lr = 1 To NoCells
Sws.Cells(6, 17) = Lr / NoCells
For Sr = 14 To 28
For Sc = 13 To 13
If ((Sr - 12) Mod 3 = 0) Then
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
End If
Next Sc
Next Sr
'Main Block 1 Data
For Sr = 14 To 28
For Sc = 14 To 29
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
'Main Block 2 Data
For Sr = 34 To 36
For Sc = 14 To 22
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
'Main Block 3 Data
For Sr = 38 To 40
For Sc = 14 To 18
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
'Bottom Right Side Block Data
For Sr = 37 To 39
For Sc = 21 To 21
If ((Sr - 12) Mod 3 = 0) Then
If (Sc = 14) Then
Sc = Sc + 1
End If
End If
Set MyCell = Sws.Cells(Sr, Sc)
If (Lr = 1) Then
Sws.Cells(Sr, Sc) = "='" & Lws.Cells(1, Lc) & MyCell.Address
Else
Sws.Cells(1, 1) = "='" & Lws.Cells(Lr, Lc) & MyCell.Address
Sws.Cells(Sr, Sc) = Sws.Cells(Sr, Sc) + Sws.Cells(1, 1)
End If
Next Sc
Next Sr
Next Lr
Sws.Cells(2, 17) = Now()
Exit Sub
ErrorHandling:
Worksheets("Errors").Cells(Err, 1) = Now()
Worksheets("Errors").Cells(Err, 2) = Lws.Cells(Lr, Lc - 2)
Worksheets("Errors").Cells(Err, 3) = Lws.Cells(Lr, Lc - 1)
Worksheets("Errors").Cells(Err, 4) = MyCell.Address
Worksheets("Errors").Cells(Err, 5) = Worksheets("Testing").Cells(1, 1)
Worksheets("Testing").Cells(1, 1) = 0
Err = Err + 1
Resume Next
End Sub
I do realise there is a fair bit of repeated code there and it can be streamlined at least visually, but I am kind of a VBA hack at the moment, so be kind...
Any advice on reducing the run time of the macro would be appreciated.
Thanks in advance
Tim.