DocumentLibraryVersions - excel

The following code was working but something happened and now it hangs on
Set DocVersions=Activeworkbook.DocumentLibraryVersions
I have even tried simple subs that with only the Dim and Set lines and it just hangs. I have also tried removing the Reference to the Microsoft Office 16.0 Object Library.
Not even sure what else to try
Sub getVersions()
Dim DocVersions As DocumentLibraryVersions
Dim DVersion As DocumentLibraryVersion
Dim clipobj As New DataObject
Dim clipdata As String
Dim i As Integer
Set DocVersions = ActiveWorkbook.DocumentLibraryVersions
i = DocVersions.Count
For Each DVersion In DocVersions
i = i - 1
Debug.Print i
clipdata = clipdata & DVersion.Index & vbTab & _
DVersion.Modified & vbTab & _
DVersion.ModifiedBy & vbTab & _
DVersion.Comments & vbCr
Debug.Print "index " & DVersion.Index
Debug.Print "comment " & DVersion.Comments
'Debug.Print "creator " & DVersion.Creator
Debug.Print "Modified Date " & DVersion.Modified
Debug.Print "Modified By " & DVersion.ModifiedBy
' Debug.Print "application " & DVersion.Application
Next
Set DocVersions = Nothing
Set DVersion = Nothing
clipobj.SetText clipdata
clipobj.PutInClipboard
MsgBox "Version Info Placed on Clipboard"
End Sub

I've had exactly the same problem when the following was hanging up the process:
Set DocVersions=Activeworkbook.DocumentLibraryVersions
After checking out the file for the first time and checking it in again, then the code continues as expected and does no longer hang at this point.

Related

.ShowAllData after Advanced Filter, Table not fully "clearing"

I've got an issue with a search function I'm building.
The actual filter seems to work pretty well and returns what is expected. The user selects criteria from several drop down lists, those are then written to the criteria field that is used in the advanced filter.
The Problem comes when I go to clear the advanced filter (code below). The table does indeed get "cleared", however there is really odd.. Formatting? afterwards.
nearly all of the rows on the table have the same background (instead of alternating light - dark - light etc), except the rows that had been the results of the previous filter.
this is causing issues when a new filter is applied to the table, wherein all rows AFTER the last row from the previous filter will not get hidden, and if the table is "cleared" again, only the rows UP UNTIL that last row will show, requiring me to manually unhide those rows at the end of the datatable.
The weirdness does correct itself after double clicking into a cell to edit and then clicking out of it. This isn't a feasible fix however and I'm not even sure how to code something like that in...
I know that applying a filter over a filter can create weirdness but this is happening even when I run things manually line by line.
I'm honestly not sure what I'm doing wrong here or what's happening with the code so if anyone has any insight I'd be grateful!
Public Sub Apply_Filters(Optional button_name As String)
Const ProcName As String = "Apply_Filters"
On Error GoTo Whoa
Dim WsCP As Worksheet: Set WsCP = ActiveWorkbook.Sheets("Core Pack BDDS")
Dim WsDND As Worksheet: Set WsDND = ActiveWorkbook.Sheets("DO NOT DELETE")
Dim WsSizes As Worksheet: Set WsSizes = ActiveWorkbook.Sheets("Sizes DO NOT DELETE")
'Stuff to be able to find specific categories in the BDDS data table
Dim TableHeaders As Variant: TableHeaders = "Table1[#Headers]" 'Header row for the main data table
Dim MainDataTable As String: MainDataTable = "Table1" 'Should be the main table on the BDDS
Dim MainTable As ListObject: Set MainTable = WsCP.ListObjects(MainDataTable) 'Mimics synax to call on the main data table as a variable (to make things cleaner)
Dim WholeMainTable As Range: Set WholeMainTable = WsCP.Range(WsCP.Range(TableHeaders), WsCP.Range(TableHeaders).End(xlDown))
Dim Grp1Criteria As Range
Dim StartTime As Double
Dim ElapsedTime As Double
'Dim button_name As String: button_name = "Test"
'StartTime = MicroTimer
WsSizes.Range("AD10:AP10").Calculate 'ensuring cells are updated before use
WsSizes.Range("AD14:AJ14").Calculate 'ensuring cells are updated before use
WsSizes.Range("AD16:AH16").Calculate 'ensuring cells are updated before use
If WsSizes.Range("AD10").Value = 0 And WsSizes.Range("AD14").Value = 0 And WsSizes.Range("AD16").Value = 0 Then
Debug.Print button_name & " - " & ProcName & " - " & " Filters NOT applied"
GoTo SafeExit
Else
Call Clear_BDDS_Table
WsDND.Range("BZ4:CS4").Calculate 'ensuring cells are updated before use
Set Grp1Criteria = WsDND.Range("BZ3").CurrentRegion
WholeMainTable.AdvancedFilter xlFilterInPlace, Grp1Criteria
Debug.Print button_name & " - " & ProcName & " - " & " Filters applied"
End If
ElapsedTime = MicroTimer - StartTime
SafeExit:
Debug.Print button_name & " - " & ProcName & " - " & ElapsedTime & " seconds"
Exit Sub
Whoa:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
MsgBox "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume SafeExit
End Sub
The problem seems to be coming from when I'm trying to clear the filters. I use the following code
Public Sub Clear_BDDS_Table(Optional button_name As String)
Const ProcName As String = "Clear_BDDS_Table"
On Error GoTo Whoa
Dim WsCP As Worksheet: Set WsCP = Sheets("Core Pack BDDS")
Dim TableHeaders As Variant: TableHeaders = "Table1[#Headers]" 'Header row for the main data table
Dim MainDataTable As String: MainDataTable = "Table1" 'Should be the main table on the BDDS
Dim MainTable As ListObject: Set MainTable = WsCP.ListObjects(MainDataTable) 'Mimics synax to call on the main data table as a variable (to make things cleaner)
Dim WholeMainTable As Range: Set WholeMainTable = WsCP.Range(WsCP.Range(TableHeaders), WsCP.Range(TableHeaders).End(xlDown))
If WsCP.FilterMode = True Then
WsCP.ShowAllData
End If
Debug.Print button_name & " - " & ProcName & " ran successfully"
SafeExit:
Exit Sub
Whoa:
Debug.Print button_name & " - " & "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
MsgBox "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume SafeExit
End Sub
I seem to have figured out the problem.
This post here was helpful in fixing this problem...
autofilter not including all rows when filtering using vba
Seems to have stemmed from when I was declaring the table range at the beginning of the Apply_Filters sub.
VBA stored the last row in that range as the end of the table and after the table was cleared that stayed as the last row.
Dim TableHeaders As Variant: TableHeaders = "Table1[#Headers]" 'Header row for the main data table
Dim MainDataTable As String: MainDataTable = "Table1" 'Should be the main table on the BDDS
Dim MainTable As ListObject: Set MainTable = WsCP.ListObjects(MainDataTable) 'Mimics synax to call on the main data table as a variable (to make things cleaner)
Dim WholeMainTable As Range
Dim Grp1Criteria As Range
Dim StartTime As Double
Dim ElapsedTime As Double
'
'Dim button_name As String: button_name = "Test"
'StartTime = MicroTimer
WsSizes.Range("AD10:AP10").Calculate 'ensuring cells are updated before use
WsSizes.Range("AD14:AJ14").Calculate 'ensuring cells are updated before use
WsSizes.Range("AD16:AH16").Calculate 'ensuring cells are updated before use
If WsSizes.Range("AD10").Value = 0 And WsSizes.Range("AD14").Value = 0 And WsSizes.Range("AD16").Value = 0 Then
Debug.Print button_name & " - " & ProcName & " - " & " Filters NOT applied"
GoTo SafeExit
Else
Call Clear_BDDS_Table
WsDND.Range("BZ4:CS4").Calculate 'ensuring cells are updated before use
Set WholeMainTable = WsCP.Range(WsCP.Range(TableHeaders), WsCP.Range(TableHeaders).End(xlDown))
Set Grp1Criteria = WsDND.Range("BZ3").CurrentRegion
WholeMainTable.AdvancedFilter xlFilterInPlace, Grp1Criteria
Debug.Print button_name & " - " & ProcName & " - " & " Filters applied"
End If
Moving the declaration of the range AFTER clearing the table fixed my issue.
Live and learn, hope this might help someone else in the future.

Looking for the fastest way to check if an executable file is still running using excel vba

I have a codes that checks if an executable file is still running or not, but the problem is I find it quite slow when checking if the executable file is running or not. Is there a fastest way to do it?
Public Function IsExeRunning(sExeName As String, Optional sComputer As
String = ".") As Boolean
On Error GoTo Error_Handler
Dim objProcesses As Object
Set objProcesses = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2").ExecQuery("SELECT * FROM Win32_Process WHERE Name like '" & sExeName & "'") ' = '" & sExeName & "'")
If objProcesses.Count <> 0 Then IsExeRunning = True
Error_Handler_Exit:
On Error Resume Next
Set objProcesses = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: IsExeRunning" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
This might be not working exactly as you are expecting as the like query isn't quite implemented correctly. I've fixed this and added a few optimizations, mainly reducing the number of returned query terms, adding an exact match method, and added a caching method to store a reference to the computer prior to the query.
Option Explicit
'Function averages 0.03 seconds on my machine
Public Function IsExeRunning(sExeName As String, _
Optional sComputer As String = ".", _
Optional ExactMatch As Boolean = False) As Boolean
On Error GoTo Error_Handler
Static Computer As Object
Dim Process As Object
Dim SearchQuery As String
IsExeRunning = False
'Cache Computer reference
If Computer Is Nothing Or sComputer <> "." Then Set Computer = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")
'Build query
If ExactMatch Then
SearchQuery = "SELECT Name FROM Win32_Process WHERE Name = '" & sExeName & "'"
Else
SearchQuery = "SELECT Name FROM Win32_Process WHERE Name like '%" & sExeName & "%'"
End If
Set Process = Computer.ExecQuery(SearchQuery)
If Process Is Nothing Then Exit Function
If Process.Count = 0 Then Exit Function
IsExeRunning = True
Error_Handler_Exit:
Exit Function
Error_Handler:
Resume Error_Handler_Exit
End Function
Sub TestRunner()
Dim t As Single
t = Timer
Debug.Print "Function returns " & IsExeRunning("Excel", ".", False) & " took: " & Timer - t & " seconds"
End Sub

Excel-VBA - list controls of all userforms for ANY given workbook

Task
My goal is to list all controls of all UserForms for ANY given workbook. My code works for all workbooks within the workbooks collection other than the calling workbook (ThisWorkBook).
Problem
If I try to list all the userforms' controls regarding the calling workbook, I get Error 91 Object variable or With block variable not set at numbered error line 200 (so called ERL). The code below is intently broken into 2 redundant portions, to show the error explicitly. Any help is appreciated.
Code
Sub ListWBControls()
' Purpose: list ALL userform controls of a given workbook within workbooks collection
'
Dim bProblem As Boolean
Dim vbc As VBIDE.VBComponent ' module, Reference to MS VBA Exte 5.3 needed !!!
Dim ctrl As MSForms.Control
Dim i As Integer, imax As Integer ' control counters
Dim cnr As Long, vbcnr As Long
Dim sLit As String
Dim sMsg As String ' result string
Dim owb As Workbook ' workbook object
Dim wb As String ' workbook name to choose by user
' --------------------
' choose Workbook name
' --------------------
wb = Me.ComboBox1.List(Me.ComboBox1.ListIndex, 0) ' << existing workbook name chosen in combobox
' check if wb is calling workbook or other
For Each owb In Workbooks
If owb.Name = wb And ThisWorkbook.Name = wb Then
bProblem = True
Exit For
End If
Next owb
' count workbooks
imax = Workbooks.Count
i = 1
' a) start message string showing workbook name
sMsg = sMsg & vbNewLine & String(25, "=") & vbNewLine & _
sLit & " WorkBook: " & Workbooks(i).Name & vbNewLine & String(25, "=")
'------------------------------
'Loop thru components (modules) - if of UserForm type
'------------------------------
For Each vbc In Workbooks(wb).VBProject.VBComponents
' Only if Component type is UserForm
If vbc.Type = vbext_ct_MSForm Then
' increment component and ctrl counters
sLit = Chr(i + 64) & "."
vbcnr = vbcnr + 1000
cnr = vbcnr
' b) build message new component
sMsg = sMsg & vbNewLine & String(25, "-") & vbNewLine & sLit & cnr & " '" & _
vbc.Name & "'" & vbNewLine & String(25, "-")
'-------------------
' Loop thru controls
'-------------------
' ===================================================================
' Code is intently broken into 2 portions, to show error explicitly !
' ===================================================================
On Error GoTo OOPS ' Error handler --> Error 91: Object variable or With block variable not set
If Not bProblem Then ' part 1 - other workbooks: shown explicitly, are no problem
100 For Each ctrl In Workbooks(wb).VBProject.VBComponents(vbc.Name).Designer.Controls
' increment ctrl counter
cnr = cnr + 1
' c) build messages controls)
sMsg = sMsg & vbLf & " " & Format(cnr, "0 000") & " " & ctrlInfo(ctrl)
Next
Else ' part 2 - problem arises here (wb = calling workbook)
200 For Each ctrl In Workbooks(wb).VBProject.VBComponents(vbc.Name).Designer.Controls ' << ERROR 91
' increment ctrl counter
cnr = cnr + 1
' c) build messages controls)
sMsg = sMsg & vbLf & " " & Format(cnr, "0 000") & " " & ctrlInfo(ctrl)
Next
End If
i = i + 1 ' increment letter counter i
End If
Next vbc
' show result
Debug.Print sMsg
Exit Sub
OOPS:
MsgBox "Error No " & Err.Number & " " & Err.Description & vbNewLine & _
"Error Line " & Erl
End Sub
Helper function
Private Function ctrlInfo(ctrl As MSForms.Control) As String
' Purpose: helper function returning userform control information
ctrlInfo = Left(TypeName(ctrl) & String(5, " "), 5) & " " & _
Left(ctrl.Name & String(20, " "), 20) & vbTab & _
" .." & IIf(TypeName(ctrl.Parent) = "UserForm", "Me " & String(15, " "), _
TypeName(ctrl.Parent) & ": " & _
Left(ctrl.Parent.Caption & String(15, " "), 15)) & vbTab & _
" T " & Format(ctrl.Top, "# 000") & "/ L " & Format(ctrl.Left, "# 000")
End Function
When a form is displayed, you can't get programmatic access to its designer. You are calling ListWBControls from an open UserForm. You could close the form beforehand, and let the code which opened it in the first place build the list, and re-open it afterwards.
Example
This code goes in a Module:
Public Sub Workaround()
On Error GoTo errHandler
Dim frmUserForm1 As UserForm1
Dim bDone As Boolean
bDone = False
Do
Set frmUserForm1 = New UserForm1
Load frmUserForm1
frmUserForm1.Show vbModal
If frmUserForm1.DoList Then
Unload frmUserForm1
Set frmUserForm1 = Nothing
ListWBControls
Else
bDone = True
End If
Loop Until bDone
Cleanup:
On Error Resume Next
Unload frmUserForm1
Set frmUserForm1 = Nothing
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Cleanup
End Sub
This code goes in UserForm1 where you've put one CommandButton named cmdDoList:
Option Explicit
Private m_bDoList As Boolean
Public Property Get DoList() As Boolean
DoList = m_bDoList
End Property
Private Sub cmdDoList_Click()
m_bDoList = True
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
m_bDoList = False
Me.Hide
End Sub
The idea is to close the form, list the controls and re-open the form when cmdDoList is clicked, and to close the form for good if it is dismissed with the X button.
Found a direct solution covering most cases using the class properties of userforms and VBComponents.
I intently show the modified code below instead of re-editing. Of course, I highly appreciate the already accepted solution by #Excelosaurus :-)
Background
VBComponents have a .HasOpenDesigner property.
the calling userForm has the class properties .Controls AND can be referenced via the identifier Me.
(only the third seldom case remains unsolved and only if I don't reference these UFs directly: how to reference other userforms by a name string within the calling file IF they are active = .HasOpenDesigner is false; maybe worth a new question)
Modified code
Sub ListWBControls2()
' Purpose: list ALL userform controls of a given workbook within workbooks collection
' cf.: https://stackoverflow.com/questions/46894433/excel-vba-list-controls-of-all-userforms-for-any-given-workbook
Dim bProblem As Boolean
Dim vbc As VBIDE.VBComponent ' module, Reference to MS VBA Exte 5.3 needed !!!
Dim ctrl As MSForms.Control
Dim i As Integer, imax As Integer ' control counters
Dim cnr As Long, vbcnr As Long
Dim sLit As String
Dim sMsg As String ' result string
Dim owb As Workbook ' workbook object
Dim wb As String ' workbook name to choose by user
' ------------------
' chosen Workbook
' ------------------
wb = Me.ComboBox1.List(Me.ComboBox1.ListIndex, 0) ' << existing workbook name chosen in combobox
' count workbooks
imax = Workbooks.Count
i = 1
' a) build message new workbook
sMsg = sMsg & vbNewLine & String(25, "=") & vbNewLine & _
sLit & " WorkBook: " & Workbooks(i).Name & vbNewLine & String(25, "=")
'------------------------------
'Loop thru components (modules)
'------------------------------
For Each vbc In Workbooks(wb).VBProject.VBComponents
' Only if Component type is UserForm
If vbc.Type = vbext_ct_MSForm Then
' increment component and ctrl counters
sLit = Chr(i + 64) & "."
vbcnr = vbcnr + 1000
cnr = vbcnr
' b) build message new component
sMsg = sMsg & vbNewLine & String(25, "-") & vbNewLine & sLit & cnr & " '" & _
vbc.Name & "'" & vbNewLine & String(25, "-")
'-------------------
' Loop thru controls
'-------------------
If vbc.HasOpenDesigner Then ' i) problem for closed userforms in same file resolved
sMsg = sMsg & vbNewLine & "** " & vbc.Name & " active via Designer.Controls"
For Each ctrl In Workbooks(wb).VBProject.VBComponents(vbc.Name).Designer.Controls ' << ERROR 91
' increment ctrl counter
cnr = cnr + 1
' c) build messages controls)
sMsg = sMsg & vbLf & " " & Format(cnr, "0 000") & " " & ctrlInfo(ctrl)
Next
ElseIf vbc.Name = Me.Name Then ' ii) problem for calling userform resolved
sMsg = sMsg & vbNewLine & "** " & vbc.Name & " active via Me.Controls"
For Each ctrl In Me.Controls
' increment ctrl counter
cnr = cnr + 1
' c) build messages controls)
sMsg = sMsg & vbLf & " " & Format(cnr, "0 000") & " " & ctrlInfo(ctrl)
Next ctrl
' -----------------------------------------------------------
Else ' iii) problem reduced to other userforms within the calling file,
' but only IF OPEN
' -----------------------------------------------------------
sMsg = sMsg & vbLf & "** Cannot read controls in calling file when HasOpenDesigner property is false! **"
End If
End If
i = i + 1 ' increment letter counter i
Next vbc
' show result in textbox
Me.tbCtrls.Text = sMsg
Debug.Print sMsg
End Sub
Helper function
Private Function ctrlInfo(ctrl As MSForms.Control) As String
' Purpose: helper function returning userform control information
ctrlInfo = Left(TypeName(ctrl) & String(5, " "), 5) & " " & _
Left(ctrl.Name & String(20, " "), 20) & vbTab & _
" .." & IIf(TypeName(ctrl.Parent) = "UserForm", "Me " & String(15, " "), _
TypeName(ctrl.Parent) & ": " & _
Left(ctrl.Parent.Caption & String(15, " "), 15)) & vbTab & _
" T " & Format(ctrl.Top, "# 000") & "/ L " & Format(ctrl.Left, "# 000")
End Function

Creating a self install macro?

Hello I create many macros for my co workers. The current method I have for distributing to another computer is going into the vba editor and importing.
I would really like to make a kind of "installer" for macros that would allow the user to install a new macro without having to go into the editor. I'm not sure this is even possible but any ideas are welcome!
Thanks!
You need to enable Microsoft Scripting Runtime library under references. (VBE -> Tools -> References. Check the box.)
Basically, you create a string that holds the code of the macro you want to install. Obviously, the string could be really long with many lines of code so you might need several string variables.
Dim toF As Workbook
Dim codeMod As CodeModule
Dim code As String
Dim fso As Scripting.FileSystemObject
Dim folder As folder
Dim name As String, file As String
Application.ScreenUpdating = False
Set fso = New FileSystemObject
Set folder = fso.GetFolder("C:\folder\here")
name = nameOfFileHere
file = folder & "\" & name
Set toF = Workbooks.Open(file)
'modify ThisWorkbook to place it elsewhere
Set codeMod = toF.VBProject.VBComponents("ThisWorkbook").CodeModule
'erase everything if code already exists
If codeMod.CountOfLines > 0 Then
codeMod.DeleteLines 1, codeMod.CountOfLines
End If
'dump in new code
code = _
"Private Sub Workbook_Open()" & vbNewLine & _
" Dim user as String" & vbNewLine & _
" Dim target as String" & vbNewLine & _
" user = Application.UserName" & vbNewLine & _
" target = """ & findUser & """" & vbNewLine & _
" If user = target then" & vbNewLine & _
" MsgBox ""I just dumped in some code.""" & vbNewLine & _
" End if" & vbNewLine & _
"End Sub" & vbNewLine
With codeMod
.InsertLines .CountOfLines + 1, code
End With
Application.ScreenUpdating = True

Faster Way to Import Excel Spreadsheet to Array With ADO

I am trying to import and sort data from a large excel report into a new file using Excel 2007 VBA. I have come up with two methods so far for doing this:
Have Excel actually open the file (code below), gather all data into arrays and output the arrays onto new sheets in the same file and save/close it.
Public Sub GetData()
Dim FilePath As String
FilePath = "D:\File_Test.xlsx"
Workbooks.OpenText Filename:=FilePath, FieldInfo:=Array(Array(2, 2))
ActiveWorkbook.Sheets(1).Select
End Sub
Use ADO to get all data out of the closed workbook, import the whole datasheet into an array (code below) and sort data from there and then output data into a new workbook and save/close that.
Private Sub PopArray() 'Uses ADO to populate an array that will be used to sort data
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim Getvalue, SourceRange, SourceFile, dbConnectionString As String
SourceFile = "D:\File_Test.xlsx"
SourceRange = "B1:Z180000"
dbConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set dbConnection = New ADODB.Connection
dbConnection.Open dbConnectionString 'open the database connection
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
Arr = rs.GetRows
UpBound = UBound(Arr, 2)
rs.Close
End Sub
The test file used has about 65000 records to sort through (about a third of what I will end up using it for). I was kind of disappointed when the ADO version only performed marginally better than the open worksheet (~44 seconds vs ~40 seconds run time). I was wondering if there is some way to improve the ADO import method (or a completely different method - ExecuteExcel4Macro maybe? - if there is one) that would boost my speed. The only thing I could think of was that I am using "B1:Z180000" as my SourceRange as a maximum range that is then truncated by setting Arr = rs.GetRows to accurately reflect the total number of records. If that is what is causing the slow down, I'm not sure how I would go about finding how many rows are in the sheet.
Edit - I am using Range("A1:A" & i) = (Array) to insert data into the new worksheet.
This answer might not be what you are looking for but I still felt compelled to post it based on your side note [...] or a completely different method ]...].
Here, I am working with files of 200MB (and more) each which are merely text files including delimiters. I do not load them into Excel anymore. I also had the problem that Excel was too slow and needs to load the entire file. Yet, Excel is very fast at opening these files using the Open method:
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
In this case Excel is not loading the entire file but merely reading it line by line. So, Excel can already process the data (forward it) and then grab the next line of data. Like this Excel does not neet the memory to load 200MB.
With this method I am then loading the data in a locally installed SQL which transfers the data directly to our DWH (also SQL). To speed up the transfer using the above mething and getting the data fast into the SQL server I am transferring the data in chunks of 1000 rows each. The string variable in Excel can hold up to 2 billion characters. So, there is not problem there.
One might wonder why I am not simply using SSIS if I am already using a local installation of SQL. Yet, the problem is that I am not the one loading all these files anymore. Using Excel to generate this "import tool" allowed me to forward these tools to others, who are now uploading all these files for me. Giving all of them access to SSIS was not an option nor the possibility of using a destined network drive where one could place these files and SSIS would automatically load them (ever 10+ minutes or so).
In the end my code looks something like this.
Set conRCServer = New ADODB.Connection
conRCServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
& "DATA SOURCE=" & Ref.Range("C2").Value2 & ";" _
& "INITIAL CATALOG=" & Ref.Range("C4").Value & ";" _
& "Integrated Security=SSPI "
On Error GoTo SQL_ConnectionError
conRCServer.Open
On Error GoTo 0
'Save the name of the current file
strCurrentFile = ActiveWorkbook.Name
'Prepare a dialog box for the user to pick a file and show it
' ...if no file has been selected then exit
' ...otherwise parse the selection into it's path and the name of the file
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Extracts", "*.csv")
Application.FileDialog(msoFileDialogOpen).Title = "Select ONE Extract to import..."
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strFileToPatch = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Else
Exit Sub
End If
'Open the Extract for import and close it afterwards
intPointer = FreeFile()
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
intCounter = 0
strSQL = vbNullString
Do Until EOF(intPointer)
Line Input #intPointer, strLine
If Left(strLine, 4) = """###" Then Exit Sub
'*********************************************************************
'** Starting a new SQL command
'*********************************************************************
If intCounter = 0 Then
Set rstResult = New ADODB.Recordset
strSQL = "set nocount on; "
strSQL = strSQL & "insert into dbo.tblTMP "
strSQL = strSQL & "values "
End If
'*********************************************************************
'** Transcribe the current line into SQL
'*********************************************************************
varArray = Split(strLine, ",")
strSQL = strSQL & " (" & varArray(0) & ", " & varArray(1) & ", N'" & varArray(2) & "', "
strSQL = strSQL & " N'" & varArray(3) & "', N'" & varArray(4) & "', N'" & varArray(5) & "', "
strSQL = strSQL & " N'" & varArray(6) & "', " & varArray(8) & ", N'" & varArray(9) & "', "
strSQL = strSQL & " N'" & varArray(10) & "', N'" & varArray(11) & "', N'" & varArray(12) & "', "
strSQL = strSQL & " N'" & varArray(13) & "', N'" & varArray(14) & "', N'" & varArray(15) & "' ), "
'*********************************************************************
'** Execute the SQL command in bulks of 1.000
'*********************************************************************
If intCounter >= 1000 Then
strSQL = Mid(strSQL, 1, Len(strSQL) - 2)
rstResult.ActiveConnection = conRCServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0
If Not rstResult.EOF And Not rstResult.BOF Then
strErrorMessage = "The server returned the following error message(s):" & Chr(10)
While Not rstResult.EOF And Not rstResult.BOF
strErrorMessage = Chr(10) & strErrorMessage & rstResult.Fields(0).Value
rstResult.MoveNext
Wend
MsgBox strErrorMessage & Chr(10) & Chr(10) & "Aborting..."
Exit Sub
End If
End If
intCounter = intCounter + 1
Loop
Close intPointer
Set rstResult = Nothing
Exit Sub
SQL_ConnectionError:
Y = MsgBox("Couldn't connect to the server. Please make sure that you have a working internet connection. " & _
"Do you want me to prepare an error-email?", 52, "Problems connecting to Server...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C7").Value2
.CC = Ref.Range("C8").Value2
.Subject = "Problems connecting to database '" & Ref.Range("C4").Value & "' on server '" & Ref.Range("C2").Value & "'"
.HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
"</span><br><br>Error report from the file '" & _
"<span style=""color:blue"">" & ActiveWorkbook.Name & _
"</span>' located and saved on '<span style=""color:blue"">" & _
ActiveWorkbook.Path & "</span>'.<br>" & _
"Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
"Computer Name: <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
"Logged in as: <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
"Domain Server: <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
"User DNS Domain: <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
"Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
"Excel Version: <span style=""color:green;"">" & Application.Version & "</span><br>" & _
"<br><span style=""font-size:10px""><br>" & _
"<br><br>---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
SQL_StatementError:
Y = MsgBox("There seems to be a problem with the SQL Syntax in the programming. " & _
"May I send an error-email to development team?", 52, "Problems with the coding...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C8").Value2
'.CC = ""
.Subject = "Problems with the SQL Syntax in file '" & ActiveWorkbook.Name & "'."
.HTMLBody = "<span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---" & _
"</span><br><br>" & _
"Error report from the file '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Name & _
"</span>" & _
"' located and saved on '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Path & _
"</span>" & _
"'.<br>" & _
"It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
"SQL-Code causing the problems:" & _
"<br><br><span style=""color:green;"">" & _
strSQL & _
"</span><br><br><span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
End Sub
i think that #Mr. Mascaro is right the easiest way to past your data from a Recordset into a spreadsheet is:
Private Sub PopArray()
.....
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
'' This is faster
Range("A1").CopyFromRecordset rs
''Arr = rs.GetRows
End Sub
but if you still want to use Arrays you could try this:
Sub ArrayTest
'' Array for Test
Dim aSingleArray As Variant
Dim aMultiArray as Variant
'' Set values
aSingleArray = Array("A","B","C","D","E")
aMultiArray = Array(aSingleArray, aSingleArray)
'' You can drop data from the Array using 'Resize'
'' Btw, your Array must be transpose to use this :P
Range("A1").Resize( _
UBound(aMultiArray(0), 1) + 1, _
UBound(aMultiArray, 1) + 1) = Application.Transpose(aMultiArray)
End Sub

Resources