Useful VBA code collection for Microsoft Excel

Here you will get useful VBA codes to increase your productivity in Microsoft Excel. VBA is a tool in Excel which enables you to customize Excel, create custom functions, create forms, automate tasks and more.

Code 1. Make Multiple Sheets from a List

By using this code, you will be able to quickly create multiple sheets from a name list that is given in a range in Excel.

Sub CreateSheets()
    Dim sheetNames As Range
    Set sheetNames = Range("J18:J20") 'change range to match your list of names
    
    Dim sheetName As Range
    For Each sheetName In sheetNames
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName.Value
    Next sheetName
End Sub

Note: In the code, you need to change the range “J18:J20” according to the range where your name list is.

Code 2. Convert Number to Words

By using this code, you can create a custom function to easily the convert numeric values to words in MS Excel.

Function NumberToWords(ByVal MyNumber)
    Dim UnitsArray As Variant
    Dim TensArray As Variant
    Dim TempStr As String
    Dim DecimalPlace As Integer
    Dim Count As Integer
    Dim DecimalPart As String
    Dim DecimalWords As String
    
    ' Define arrays for units and tens
    UnitsArray = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", _
        "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
    TensArray = Array("", "", "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
    
    ' Convert MyNumber to a string and trim extra spaces
    MyNumber = Trim(CStr(MyNumber))
    
    ' Find position of decimal place, if any
    DecimalPlace = InStr(MyNumber, ".")
    
    ' Convert cents (decimal part) to words
    If DecimalPlace > 0 Then
        DecimalPart = Mid(MyNumber, DecimalPlace + 1)
        MyNumber = Left(MyNumber, DecimalPlace - 1)
    Else
        DecimalPart = ""
    End If
    
    Count = 1
    Do While MyNumber <> ""
        Select Case Count
            Case 1
                TempStr = ConvertHundreds(Right(MyNumber, 3))
            Case 2
                TempStr = ConvertHundreds(Right(MyNumber, 3)) & " Thousand "
            Case 3
                TempStr = ConvertHundreds(Right(MyNumber, 3)) & " Million "
            Case 4
                TempStr = ConvertHundreds(Right(MyNumber, 3)) & " Billion "
        End Select
        NumberToWords = TempStr & NumberToWords
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
    
    NumberToWords = Application.Trim(NumberToWords)
    
    ' Add decimal part to the words
    If DecimalPart <> "" Then
        DecimalWords = " point"
        For i = 1 To Len(DecimalPart)
            DecimalWords = DecimalWords & " " & UnitsArray(Val(Mid(DecimalPart, i, 1)))
        Next i
        NumberToWords = NumberToWords & DecimalWords
    End If
End Function

Private Function ConvertHundreds(ByVal MyNumber)
    Dim Result As String
    Dim UnitsArray As Variant
    Dim TensArray As Variant
    
    UnitsArray = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", _
        "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
    TensArray = Array("", "", "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
    
    MyNumber = Right("000" & MyNumber, 3)
    
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = UnitsArray(Val(Mid(MyNumber, 1, 1))) & " Hundred "
    End If
    
    ' Convert the tens and units place.
    If Val(Mid(MyNumber, 2, 2)) < 20 Then
        Result = Result & UnitsArray(Val(Mid(MyNumber, 2, 2)))
    Else
        Result = Result & TensArray(Val(Mid(MyNumber, 2, 1)))
        Result = Result & " " & UnitsArray(Val(Mid(MyNumber, 3, 1)))
    End If
    
    ConvertHundreds = Result
End Function

Code 3. Make Multiple PDFs from the Sheets of Excel Workbook

By using this VBA code, you can make multiple PDF reports from every single sheets of Excel workbook. PDF will be exported in the name of the sheets.

Sub ExportSheetsToPDF()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim folderPath As String
    Dim fileName As String
    
    ' Set the workbook and folder path
    Set wb = ThisWorkbook
    folderPath = wb.Path
    
    ' Loop through each worksheet in the workbook
    For Each ws In wb.Worksheets
        ' Set the file name to the worksheet name
        fileName = folderPath & "\" & ws.Name & ".pdf"
        
        ' Export the worksheet to PDF
        ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileName, Quality:=xlQualityStandard
    Next ws
    
    ' Inform the user that the process is complete
    MsgBox "All sheets have been exported as individual PDF files.", vbInformation
End Sub

Code 4. TOCOL and TOROW function Alternative for Old Versions

By using these codes, you can put the data in one single column or row. It works like the TOCOL and TOROW functions in new Exccel versions.

TOCOL Code

Sub CombineRowsToColumn()
    Dim inputRange As Range
    Dim outputCell As Range
    Dim result() As Variant
    Dim cell As Range
    Dim i As Long
    
    On Error Resume Next
    Set inputRange = Application.InputBox("Please select the range to convert to column:", "Select Range", Type:=8)
    On Error GoTo 0
    
    
    If inputRange Is Nothing Then
        MsgBox "Operation terminated.", vbInformation
        Exit Sub
    End If
    
    
    ReDim result(1 To inputRange.Cells.Count)
    
   
    i = 1
    For Each cell In inputRange.Cells
        If cell.Value <> "" Then
            result(i) = cell.Value
            i = i + 1
        End If
    Next cell
    
    
    ReDim Preserve result(1 To i - 1)
    
    
    result = WorksheetFunction.Transpose(result)
    
    
    On Error Resume Next
    Set outputCell = Application.InputBox("Please select the cell where you want to put the data in column:", "Select Output Cell", Type:=8)
    On Error GoTo 0
    
    
    If outputCell Is Nothing Then
        MsgBox "Operation terminated.", vbInformation
        Exit Sub
    End If
    
    
    outputCell.Resize(UBound(result), 1).Value = result
    
    MsgBox "Data has been converted to column", vbInformation
End Sub

TOROW Code

Sub CombineDataToRow()
    Dim inputRange As Range
    Dim outputCell As Range
    Dim result() As Variant
    Dim cell As Range
    Dim i As Long
    
    On Error Resume Next
    Set inputRange = Application.InputBox("Please select the range to convert to row:", "Select Range", Type:=8)
    On Error GoTo 0
    
    If inputRange Is Nothing Then
        MsgBox "Operation terminated.", vbInformation
        Exit Sub
    End If
    
    ReDim result(1 To inputRange.Cells.Count)
    
    i = 1
    For Each cell In inputRange.Cells
        If cell.Value <> "" Then
            result(i) = cell.Value
            i = i + 1
        End If
    Next cell
    
    ReDim Preserve result(1 To i - 1)
    
    
    
    On Error Resume Next
    Set outputCell = Application.InputBox("Please select the cell where you want to put the data in row:", "Select Output Cell", Type:=8)
    On Error GoTo 0
    
    If outputCell Is Nothing Then
        MsgBox "Operation terminated.", vbInformation
        Exit Sub
    End If
    
    
    outputCell.Resize(1, UBound(result)).Value = result
    
    MsgBox "Data has been converted to a row", vbInformation
End Sub

Find Combination Function Code

Option Explicit

Function FindCombination(numbers As Range, target As Double) As String
    Dim arr() As Double
    Dim result As String
    Dim found As Boolean
    
    ' Convert the range to an array
    arr = RangeToArray(numbers)
    
    ' Find the combination
    result = ""
    found = FindSumCombination(arr, target, "", result)
    
    If found Then
        FindCombination = result
    Else
        FindCombination = "No combination found"
    End If
End Function

Private Function FindSumCombination(numbers() As Double, target As Double, currentCombination As String, ByRef result As String) As Boolean
    Dim i As Long
    Dim newTarget As Double
    Dim newCombination As String
    
    For i = LBound(numbers) To UBound(numbers)
        ' Subtract the current number from the target
        newTarget = target - numbers(i)
        
        ' Create the new combination string
        If currentCombination = "" Then
            newCombination = CStr(numbers(i))
        Else
            newCombination = currentCombination & ", " & numbers(i)
        End If
        
        ' Check if we found the target
        If newTarget = 0 Then
            result = newCombination
            FindSumCombination = True
            Exit Function
        ElseIf newTarget > 0 Then
            ' Create a new array excluding the current number
            Dim reducedArray() As Double
            reducedArray = RemoveElement(numbers, i)
            
            ' Recursively check the reduced array
            If FindSumCombination(reducedArray, newTarget, newCombination, result) Then
                FindSumCombination = True
                Exit Function
            End If
        End If
    Next i
    
    FindSumCombination = False
End Function

Private Function RangeToArray(rng As Range) As Double()
    Dim arr() As Double
    Dim i As Long
    Dim cell As Range
    
    ReDim arr(1 To rng.Count)
    i = 1
    For Each cell In rng
        arr(i) = cell.Value
        i = i + 1
    Next cell
    
    RangeToArray = arr
End Function

Private Function RemoveElement(numbers() As Double, indexToRemove As Long) As Double()
    Dim arr() As Double
    Dim i As Long, j As Long
    
    ReDim arr(LBound(numbers) To UBound(numbers) - 1)
    j = LBound(arr)
    For i = LBound(numbers) To UBound(numbers)
        If i <> indexToRemove Then
            arr(j) = numbers(i)
            j = j + 1
        End If
    Next i
    
    RemoveElement = arr
End Function