VBA/Excel/Access/Word/Excel/Cell

A better way to write to a range:Filling a range

   <source lang="vb">

Sub LoopFillRange()

   Dim CurrRow As Long, CurrCol As Integer
   Dim CurrVal As Long
   CellsDown = 3
   CellsAcross = 4
   StartTime = timer
   CurrVal = 1
   Application.ScreenUpdating = False
   For CurrRow = 1 To CellsDown
       For CurrCol = 1 To CellsAcross
           ActiveCell.Offset(CurrRow - 1, _
           CurrCol - 1).value = CurrVal
           CurrVal = CurrVal + 1
       Next CurrCol
   Next CurrRow

" Display elapsed time

   Application.ScreenUpdating = True
   MsgBox Format(timer - StartTime, "00.00") & " seconds"

End Sub

</source>
   
  

Get the last cell

   <source lang="vb">

Sub GetLastCell()

  Dim RealLastRow As Long
  Dim RealLastColumn As Long
  
  Range("A1").Select
  On Error Resume Next
  RealLastRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
  RealLastColumn = Cells.Find("*", Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
  Cells(RealLastRow, RealLastColumn).Select

End Sub

</source>
   
  

Is a cell empty

   <source lang="vb">

Sub ShadeEverySecondRow()

 Dim i As Integer
 i = 2
 Do Until IsEmpty(Cells(i, 1))
   Cells(i, 1).EntireRow.Interior.ColorIndex = 15
   i = i + 2
 Loop

End Sub

</source>
   
  

Magic Squares

   <source lang="vb">

Private Sub AssignValueCell()

   Dim row1 As Integer
   Dim row2 As Integer
   Dim row3 As Integer
   Dim col1 As Integer
   Dim col2 As Integer
   Dim col3 As Integer
   Dim diagonal1 As Integer
   Dim diagonal2 As Integer
   row1 = Cells(3, "B").Value + Cells(3, "C").Value + Cells(3, "D").Value
   col1 = Cells(3, "B").Value + Cells(4, "B").Value + Cells(5, "B").Value
   diagonal1 = Cells(3, "B").Value + Cells(4, "C").Value + Cells(5, "D").Value
   Cells(6, "B").Value = col1
   Cells(3, "E").Value = row1
   Cells(6, "E").Value = diagonal1

End Sub

</source>
   
  

Moving the pointer to the cell containing the greatest value

   <source lang="vb">

Sub GoToMax()

   Dim WorkRange As range
   If TypeName(Selection) <> "Range" Then Exit Sub
   If Selection.Count = 1 Then
       Set WorkRange = Cells
   Else
       Set WorkRange = Selection
   End If
   MaxVal = Application.Max(WorkRange)
   On Error Resume Next
   WorkRange.Find(What:=MaxVal, _
       After:=WorkRange.range("A1"), _
       LookIn:=xlValues, _
       LookAt:=xlPart, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False _
       ).Select
   If Err <> 0 Then MsgBox "Max value was not found: " _
    & MaxVal

End Sub

</source>
   
  

Nest If statement in Do Loop Until for cells

   <source lang="vb">

Sub m()

   Dim I As Integer
   I = 1
   Do
      If (Cells(I, "A").Value = "A") Then
         MsgBox ("I found a A in row " & Str(I))
      End If
      I = I + 1
   Loop Until (Cells(I, "A").Value = "")

End Sub

</source>
   
  

Nest If statement in Do Loop While with comparison operators

   <source lang="vb">

Sub IfDo()

   Dim I As Integer
   I = 1
   Do
         If (Cells(I, "A").Value = "A") Then
               MsgBox ("I found a A in row " & Str(I))
         End If
         I = I + 1
   Loop While (Cells(I, "A").Value <> "")

End Sub

</source>
   
  

Selects cell G4

   <source lang="vb">

Sub sel()

    range("G4").Select

End Sub

</source>
   
  

Transposing is taking a rectangular block of data and rotating it so that columns become rows and vice versa.

   <source lang="vb">

Public Sub Transpose()

   Dim I As Integer
   Dim J As Integer
   Dim transArray() As Variant
   Dim numRows As Integer
   Dim numColumns As Integer
   Dim colIndex As Integer
   Dim rowIndex As Integer
   Dim inputRange As Range
   Set inputRange = ActiveWindow.Selection
   colIndex = inputRange.Column
   rowIndex = inputRange.Row
   numRows = inputRange.Rows.Count
   numColumns = inputRange.Columns.Count
   ReDim transArray(numRows - 1, numColumns - 1)
   For I = colIndex To numColumns + colIndex - 1
       For J = rowIndex To numRows + rowIndex - 1
           transArray(J - rowIndex, I - colIndex) = Cells(J, I).Value
       Next J
   Next I
   inputRange.ClearContents
   For I = colIndex To numRows + colIndex - 1
       For J = rowIndex To numColumns + rowIndex - 1
           Cells(J, I).Value = transArray(I - colIndex, J - rowIndex)
       Next J
   Next I
   Cells(rowIndex, colIndex).Select

End Sub

</source>
   
  

Use arrays to fill ranges faster

   <source lang="vb">

Sub ArrayFillRange()

   Dim TempArray() As Integer
   Dim TheRange As range
   CellsDown = 3
   CellsAcross = 4
   StartTime = timer
   ReDim TempArray(1 To CellsDown, 1 To CellsAcross)
   Set TheRange = ActiveCell.range(Cells(1, 1), Cells(CellsDown, CellsAcross))
   CurrVal = 0
   Application.ScreenUpdating = False
   For I = 1 To CellsDown
       For J = 1 To CellsAcross
           TempArray(I, J) = CurrVal + 1
           CurrVal = CurrVal + 1
       Next J
   Next I
   TheRange.value = TempArray
   Application.ScreenUpdating = True
   MsgBox Format(timer - StartTime, "00.00") & " seconds"

End Sub

</source>
   
  

Uses nested For/Next loops to count the total number of cells used in all open worksheets:

   <source lang="vb">

Public Sub numCells()

   Dim I As Integer
   Dim K As Integer
   Dim numCells As Long
   For K = 1 To Workbooks.Count   "Loop through workbooks
       Workbooks(K).Activate
       For I = 1 To Worksheets.Count  "Loop through worksheets
           numCells = numCells + Worksheets(I).UsedRange.Count
       Next I
   Next K
   MsgBox (numCells)

End Sub

</source>