Hello,
I have been programming VBA for a little over a year at a department in a large enterprise and have managed to slop my way through a few projects. My main thing are Excel consolidations since I figured out how to use formula arrays to read data from closed workbooks on our SharePoint site.
Lately however I've been craving a little more speed. The first consolidation that I worked on here took an hour and a half to get one column out of 200+ workbooks. I managed to get that down to 8.5 minutes my first try and now I have it down to a minute and a half. But the minute and a half model uses data that's refreshed every hour. I would like a faster, reliable way to extract the data so I've been experimenting with ADODB.
I downloaded and tweaked the following code:
And this:
This:
This is the main subroutine:
This code reads through a column of hyperlinks, changes the address to a DAV link and reads the column into a recordset and (just so I can see the data) copies it into a sheet.
I can get data using this and it also has the advantage of being able to be stored and manipulated in memory. A formula array has to go on a sheet and then be read into an array. However ADODB seems to be very slow. Is there any way this code can be optimized for speed or is that just the way it is with ADODB?
I have been programming VBA for a little over a year at a department in a large enterprise and have managed to slop my way through a few projects. My main thing are Excel consolidations since I figured out how to use formula arrays to read data from closed workbooks on our SharePoint site.
Lately however I've been craving a little more speed. The first consolidation that I worked on here took an hour and a half to get one column out of 200+ workbooks. I managed to get that down to 8.5 minutes my first try and now I have it down to a minute and a half. But the minute and a half model uses data that's refreshed every hour. I would like a faster, reliable way to extract the data so I've been experimenting with ADODB.
I downloaded and tweaked the following code:
Code:
Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End SubAnd this:
Code:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End FunctionThis:
Code:
Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End FunctionThis is the main subroutine:
Code:
Sub ADO_Test()
Dim strPath As Variant
Dim strLnkSht As String
Dim strDstSht As String
Dim rngDst As Range
Dim cntCol As Integer
Dim strColLetter As String
Dim intLnkCol As Integer
strLnkSht = "Links"
strDstSht = "Dest"
intLnkCol = 2
For cntCol = 2 To Sheets(strLnkSht).Hyperlinks.Count
strColLetter = Split(Cells(1, cntCol).Address, "$")(1)
Sheets(strLnkSht).Activate
Set rngDst = Sheets(strDstSht).Range(strColLetter & "1:" & strColLetter & "439")
strPath = Sheets(strLnkSht).Range(Cells(cntCol, intLnkCol), Cells(cntCol, intLnkCol)).Hyperlinks(1).Address
strPath = Replace(strPath, "https://sps.mycompany.com", "\\sps.mycompany.com@SSL\DavWWWRoot")
strPath = Replace(strPath, "/", "\")
Sheets(strDstSht).Activate
'Get the cell values and copy it in the destrange
GetData strPath, "E-1_TR", "I25:I464", rngDst, False, False
Next cntCol
End SubThis code reads through a column of hyperlinks, changes the address to a DAV link and reads the column into a recordset and (just so I can see the data) copies it into a sheet.
I can get data using this and it also has the advantage of being able to be stored and manipulated in memory. A formula array has to go on a sheet and then be read into an array. However ADODB seems to be very slow. Is there any way this code can be optimized for speed or is that just the way it is with ADODB?
