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