VBA/Excel/Access/Word/Excel/Cell

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

 
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

Get the last cell

 
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

Is a cell empty

 
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

Magic Squares

 
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

Moving the pointer to the cell containing the greatest value

 
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

Nest If statement in Do Loop Until for cells

 
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

Nest If statement in Do Loop While with comparison operators

 
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

Selects cell G4

 
Sub sel()
     range("G4").Select
End Sub

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

 
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

Use arrays to fill ranges faster

 
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

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

 
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