Sum all digits of a number

Here below find the code to sum all the digits of a number

Subprocedure will ask an input and return a message box of sum.

Sub sum_digits()

num = InputBox("Enter digits to sum")

    Do While Number >= 1

       ss = ss + num Mod 10

        num = Int(num / 10)

    Loop

    MsgBox ss

End Sub

Asterisk Triangle in Excel VBA Through Loops

In below code you can see how to create different Triangles of asterisk in Excel VBA through Loops.

You can change the value in Cells if you want different than asterisk.

This is one of the most asked interview questions about excel vba.

Code used to create above

Sub loop_test1()
    For i = 1 To 20
        For j = 1 To 21 - i
        Cells(i, j).Value = "*"
        Cells(i, j).Interior.Color = vbYellow
        Next
    Next
    Range("A1").CurrentRegion.Select
    Selection.Columns.AutoFit
End Sub

Code for Loop Test 2 used to create above triangle

Sub loop_test2()
    For i = 20 To 1 Step -1
        For j = 1 To i
        Cells(i, j).Value = "*"
        Cells(i, j).Interior.Color = vbYellow
        Next
    Next
    Range("A1").CurrentRegion.Select
    Selection.Columns.AutoFit
End Sub

Code for Loop test 3 (smallest triangle)

Sub loop_test3()
    For i = 1 To 3
        For j = 4 - i To i + 2
        Cells(i, j).Value = "*"
      Cells(i, j).Interior.Color = vbYellow
        Next
    Next
    Range("A1").CurrentRegion.Select
    Selection.Columns.AutoFit
End Sub

Code created the above Pyramid is here

Sub loop_test4()

    For i = 1 To 10

        For j = 10 - i + 1 To i + 9

        Cells(i, j).Value = "*"

      Cells(i, j).Interior.Color = vbYellow

        Next

    Next

    Range("J1").CurrentRegion.Select

    Selection.Columns.AutoFit

End Sub

Consolidation of Data from folders and subfolders using recursion

Option Explicit
Dim wb As Workbook
Dim lr As Long
Dim lrt As Long
Sub GetAllFiles()

    Dim Directory As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select a location containing the files you want to list."
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            Directory = .SelectedItems(1) & "\"
        End If
    End With
 
    Cells.ClearContents
    Call RecursiveDir(Directory)
End Sub

Public Sub RecursiveDir(ByVal CurrDir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim FileName As String
    Dim PathAndName As String
    Dim i As Long
    Dim Filesize As Double

'   Make sure path ends in backslash
    If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"

'   Get files
    On Error Resume Next
    FileName = Dir(CurrDir & "*.*", vbDirectory)
    Do While Len(FileName) <> 0
      If Left(FileName, 1) <> "." Then 'Current dir
        PathAndName = CurrDir & FileName
        If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
          'store found directories
           ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1
        Else
  Set wb = Workbooks.Open(PathAndName)
   lr = ActiveWorkbook.Worksheets("Sheet1").Range("A1048576").End(xlUp).Row
   Range("A2:D" & lr).Copy
   lrt = ThisWorkbook.Worksheets("Sheet1").Range("A1048576").End(xlUp).Row + 1
   ThisWorkbook.Worksheets("Sheet1").Range("A" & lrt).PasteSpecial xlPasteAll
   wb.Close
   End If
    End If
        FileName = Dir()
    Loop
    ' Process the found directories, recursively
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub

ActiveX Data Objects (ADO)

Active X Data Objects (ADO)

Add Below Library to use ADO

Option Explicit

Sub copyfromdb()
Dim salesconn As ADODB.Connection
Dim rst As ADODB.Recordset
Set salesconn = New ADODB.Connection
Set rst = New ADODB.Recordset
salesconn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\sid\Desktop\Movies.accdb;Persist Security Info=False"

salesconn.Open

With rst
.ActiveConnection = salesconn
.Source = "select region from sales"
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With

Worksheets.Add
Range("A1").CopyFromRecordset rst.Fields
Range("A1").CopyFromRecordset rst
rst.Close

salesconn.Close

End Sub

File System Object (FSO)

FSO (File Sytstem Object)

Add Library to use early binding 

Option Explicit

Sub fso()
Dim fso As FileSystemObject
Dim name As String
Dim fldr As String
Dim rng As Range
Dim cell As Range
Dim ts As TextStream
Dim folder As folder
name = Format(Date, "mm-dd-yyyy")
fldr = "C:\Users\pc Admin\Desktop\" & name

Set fso = New FileSystemObject

If Not fso.FolderExists(fldr) Then
Set folder = fso.CreateFolder(fldr)
Else

End If
If Not fso.FileExists(fldr & "\My File.txt") Then
folder.CreateTextFile ("My File.txt")
End If
Set rng = Range("A1").CurrentRegion
Set ts = fso.OpenTextFile(fldr & "\My File.txt", ForWriting)

For Each cell In rng
ts.WriteLine cell
Next

End Sub