go home

vba code snippets


Find below a vba repository compiled with help from various sources on the Internet.

go to ..




paramVersion


'####################'
'##  paramVersion  ##'
'####################'
Function paramVersion() As String
  paramVersion = "v" & ((Year(Now) * 100000000) + (Month(Now) * 1000000) + (Day(Now) * 10000) + (Hour(Now) * 100) + Minute(Now))
End Function




doExtrapolateCellFormulaToColumn


'########################################'
'##  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


'###########################'
'##  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


'######################'
'##  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


'###################'
'##  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


'#######################'
'##  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


'#####################################'
'##  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


'###############################'
'##  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


'##########################'
'##  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


'##########################'
'##  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


'############################'
'##  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


'############################'
'##  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


'###################'
'##  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


'########################################'
'##  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


'############################'
'##  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