Find below a vba repository compiled with help from various sources on the Internet.
'####################' '## paramVersion ##' '####################' Function paramVersion() As String paramVersion = "v" & ((Year(Now) * 100000000) + (Month(Now) * 1000000) + (Day(Now) * 10000) + (Hour(Now) * 100) + Minute(Now)) End Function
'########################################'
'## doExtrapolateCellFormulaToColumn ##'
'########################################'
Sub doExtrapolateCellFormulaToColumn _
(sh As Worksheet, _
str_function As String, _
int_rowFirst As Integer, _
lng_rowLast As Long, _
str_column As String)
sh.Range(str_column & int_rowFirst).Formula = str_function
sh.Activate
Range(str_column & int_rowFirst).Select
Selection.Copy
Range(str_column & (int_rowFirst + 1) & ":" & str_column & lng_rowLast).Select
ActiveSheet.Paste
End Sub
'###########################'
'## doRetrieveMssqlData ##'
'###########################'
Sub doRetrieveMssqlData _
(sh_target As Worksheet, _
str_sql As String, _
str_range As String)
' create a connection object
Dim conn As ADODB.Connection
Set conn = New ADODB.Connection
conn.CommandTimeout = 0
' provide the connection string
Dim strConn As String
' use the sql server ole db provider
strConn = "PROVIDER=SQLOLEDB;"
' connect to the database
strConn = strConn & "Server=" & param_sqlServer & ";Database=" & param_sqlDatabase & ";"
' login parameters
strConn = strConn & "User Id=" & param_sqlUserId & ";Password=" & param_sqlPassword & ";"
' open connection
conn.Open strConn
' create a recordset object
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.CursorType = adOpenForwardOnly
With rs
' assign the connection object
.ActiveConnection = conn
' extract the required records
.Open str_sql
' copy the records into sheet
sh_target.Range(str_range).CopyFromRecordset rs
' clean-up
.Close
End With
' clean-up
conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub
'######################'
'## doSaveWorkbook ##'
'######################'
Sub doSaveWorkbook _
(str_path As String, _
str_name As String)
Dim wbSave As Workbook
Dim saveAsFilename As String
Dim tryAgain As Boolean
Dim i As Integer
Set wbSave = Excel.Workbooks(str_name)
saveAsFilename = str_path & Application.PathSeparator & str_name
tryAgain = True
i = 0
Application.DisplayAlerts = False
On Error Resume Next
Do While tryAgain
i = i + 1
If i = 1 Then
wbSave.Save
Else
wbSave.SaveAs Filename:=Replace(saveAsFilename, ".xls", "_" & i & ".xls")
End If
If Err.Number <> 1004 Then
tryAgain = False
End If
If i > 10 Then
On Error GoTo 0
End If
Loop
On Error GoTo 0
Application.DisplayAlerts = True
' clean-up
Set wbSave = Nothing
End Sub
'###################'
'## doUnHideAll ##'
'###################'
' Let op !! Werkt alleen als de beveiliging van het workbook verwijderd is !!
Sub doUnHideAll()
Dim sh As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
For Each sh In wb.Worksheets
sh.Visible = xlSheetVisible
Next sh
' clean-up
Set sh = Nothing
Set wb = Nothing
End Sub
'#######################'
'## giveCopyOfSheet ##'
'#######################'
Function giveCopyOfSheet _
(wb_source As Workbook, _
str_sheet_source As String, _
wb_destination As Workbook, _
str_sheet_destination As String) As Boolean
Dim sh As Worksheet
On Error GoTo Oops:
Set sh = wb_destination.Sheets.Add
sh.Name = str_sheet_destination
wb_source.Sheets(str_sheet_source).Cells.Copy wb_destination.Sheets(str_sheet_destination).Cells
giveCopyOfSheet = True
' clean-up
Set sh = Nothing
Exit Function
Oops:
MsgBox Err.Description
giveCopyOfSheet = False
' clean-up
Set sh = Nothing
End Function
'#####################################'
'## giveCorrespondingColumnLetter ##'
'#####################################'
Function giveCorrespondingColumnLetter _
(iCol As Integer) As String
If iCol > 52 Then
giveCorrespondingColumnLetter = Chr(Int((iCol - 1) / 52) + 64) & _
Chr(Int((iCol - 27) / 26) + 64) & _
Chr(Int((iCol - 27) Mod 26) + 65)
ElseIf iCol > 26 Then
giveCorrespondingColumnLetter = Chr(Int((iCol - 1) / 26) + 64) & _
Chr(Int((iCol - 1) Mod 26) + 65)
Else
giveCorrespondingColumnLetter = Chr(iCol + 64)
End If
End Function
'###############################'
'## giveDoesFileFolderExist ##'
'###############################'
Function giveDoesFileFolderExist _
(strFullPath As String) As Boolean
giveDoesFileFolderExist = False
On Error Resume Next
If Not Dir(strFullPath, vbDirectory) = vbNullString Then
giveDoesFileFolderExist = True
End If
On Error GoTo 0
End Function
'##########################'
'## giveDoesSheetExist ##'
'##########################'
Function giveDoesSheetExist _
(wb As Workbook, _
str_sheet As String) As Boolean
Dim sh As Worksheet
On Error Resume Next
Set sh = wb.Sheets(str_sheet)
If sh Is Nothing Then 'Doesn't exist
giveDoesSheetExist = False
Else 'Does exist
giveDoesSheetExist = True
End If
On Error GoTo 0
' clean-up
Set sh = Nothing
End Function
'##########################'
'## giveIsWorkBookOpen ##'
'##########################'
Function giveIsWorkBookOpen _
(str_workbook As String) As Boolean
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(str_workbook)
If wb Is Nothing Then 'Not open
giveIsWorkBookOpen = False
Set wb = Nothing
On Error GoTo 0
Else 'It is open
giveIsWorkBookOpen = True
Set wb = Nothing
On Error GoTo 0
End If
End Function
'############################'
'## giveLastColumnLetter ##'
'############################'
Function giveLastColumnLetter _
(sh As Worksheet) As String
Dim i As Integer
On Error Resume Next
i = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
On Error GoTo 0
If i > 0 Then
giveLastColumnLetter = giveCorrespondingColumnLetter(i)
Else
giveLastColumnLetter = ""
End If
End Function
'############################'
'## giveLastColumnNumber ##'
'############################'
Function giveLastColumnNumber _
(sh As Worksheet) As Integer
Dim i As Integer
On Error Resume Next
i = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
On Error GoTo 0
If i > 0 Then
giveLastColumnNumber = i
Else
giveLastColumnNumber = 0
End If
End Function
'###################'
'## giveLastRow ##'
'###################'
' Let op !! Werkt alleen als de beveiliging van het worksheet verwijderd is !!
Function giveLastRow _
(sh As Worksheet) As Integer
Dim i As Integer
On Error Resume Next
i = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If i > 0 Then
giveLastRow = i
Else
giveLastRow = 0
End If
End Function
'########################################'
'## giveStatusImportExcelFileIntoTab ##'
'########################################'
' LET OP .. aanzetten .. "Extra --> Verwijzingen... --> Microsoft Scripting Runtime"
Function giveStatusImportExcelFileIntoTab _
(sh_destinationTab As Worksheet, _
str_destinationRange As String, _
str_importFullPath As String, _
str_importTab As String, _
str_password As String, _
str_importColumnFirst As String, _
str_importColumnLast As String, _
int_importRowFirst As Integer) As Boolean
' init
Dim lng_rowLast As Long
Dim sh_import As Worksheet
Dim wb_import As Workbook
Dim lng_rowFirst As Long
Dim lng_colLast As Long
giveStatusImportExcelFileIntoTab = False
If (giveDoesFileFolderExist(str_importFullPath) _
And Len(str_importFullPath) > 0) Then
' wb_import open
Set wb_import = Workbooks.Open(str_importFullPath)
' sh_import
If Len(str_export) > 0 Then
Set sh_import = wb_import.Worksheets(str_importTab)
Else
Set sh_import = wb_import.Worksheets(1)
End If
' unprotect
If Len(str_password) > 0 Then
sh_import.Unprotect Password:=str_password
End If
' last row
lng_rowLast = giveLastRow(sh_import)
If lng_rowLast = 0 Then
lng_rowLast = 1
End If
' autofilter
If sh_import.AutoFilterMode = True Then
sh_import.AutoFilterMode = False
End If
' copy to destination-tab
If Not Len(str_destinationRange) > 0 Then
str_destinationRange = "A1"
End If
sh_import.Range(str_importColumnFirst & int_importRowFirst & ":" & str_importColumnLast & lng_rowLast).Copy
sh_destinationTab.Range(str_destinationRange).PasteSpecial xlPasteValues
' meta-data
lng_rowFirst = Range(str_destinationRange).Row
lng_rowLast = giveLastRow(sh_destinationTab)
lng_colLast = giveLastColumnNumber(sh_destinationTab)
' meta-data :: file-name
str_col = giveCorrespondingColumnLetter(lng_colLast + 1)
sh_destinationTab.Range(str_col & lng_rowFirst & ":" & str_col & lng_rowLast).Value = wb_import.Name
' meta-data :: import-date
str_col = giveCorrespondingColumnLetter(lng_colLast + 2)
sh_destinationTab.Range(str_col & lng_rowFirst & ":" & str_col & lng_rowLast).Value = Now()
' wb_import close
Application.DisplayAlerts = False
wb_import.Close False
Application.DisplayAlerts = True
giveStatusImportExcelFileIntoTab = True
Else
giveStatusImportExcelFileIntoTab = False
MsgBox ("FOUT -- [" & str_importFullPath & "] -- BESTAAT NIET !!")
End If
'clean-up
Set sh_import = Nothing
Set wb_import = Nothing
End Function
'############################'
'## giveStringResultFind ##'
'############################'
Function giveStringResultFind(sh As Worksheet, _
str_rngFind As String, _
str_columnReturn As String, _
str_text As String) As String
Dim lr As Integer
lr = 0
On Error Resume Next
lr = sh.Range(str_rngFind).Find(What:=str_text, _
Lookat:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If lr > 0 Then
giveStringResultFind = sh.Range(str_columnReturn & lr).Value
Else
giveStringResultFind = ""
End If
End Function