Jump to content

User:Statsrick/VBA code

From Wikipedia, the free encyclopedia

Coding tips:

  • Applicaitons to make programs run smoother
 
Application.ScreenUpdating = False 'Turn screen updating off and on again to speed up programs
Application.DisplayAlerts = False 'Turn pop ups alerts off


  • Use to make sure all variables are declared 
     Option Explicit On
  • Use public constants to be able to make dynamic changes 
      Public Const G_COLOR_CHANGE = 16777164 'light blue



'This is a simple example of a do-loop and how to use .Range
Sub loop_example()
 Dim i As Long
    For i = 1 To 274
     Sheets("Stack").Range("a" & i + 1) = Sheets("Table " & i).Range("B1")
     Sheets("Stack").Range("b" & i + 1) = Sheets("Table " & i).Range("B2")
     Sheets("Stack").Range("c" & i + 1) = Sheets("Table " & i).Range("B3")
    Next i
End Sub



'This is an example how to find the last row of a spreadsheet and to loop through all rows 
Sub new_clean()
    Dim LastRow, RowCount As Long
    LastRow = Range("A65536").End(xlUp).Row

    For RowCount = 2 To LastRow
      Range("C" & RowCount) = Range("B" & RowCount) & " " & Range("C" & RowCount)
    Next RowCount
End Sub



' Keep forumlas

Sub CreatePrettyForumlas()
     
    Application.ScreenUpdating = False 'Turn screen updating off and on again to speed up programs
    Application.DisplayAlerts = False 'Turn pop ups alerts off
    
    Dim last_row As Integer
    last_row = Worksheets("Rick-MonthlyCostandUsageofAWSS3").Range("A65536").End(xlUp).Row
    
    Worksheets("S3CostandUsagePretty").Range("A2").Formula = "='Rick-MonthlyCostandUsageofAWSS3'!C2&"" - ""&'Rick-MonthlyCostandUsageofAWSS3'!D2"
    Worksheets("S3CostandUsagePretty").Range("B2").Formula = "='Rick-MonthlyCostandUsageofAWSS3'!E2"
    Worksheets("S3CostandUsagePretty").Range("C2").Formula = "='Rick-MonthlyCostandUsageofAWSS3'!F2"
    Worksheets("S3CostandUsagePretty").Range("D2").Formula = "='Rick-MonthlyCostandUsageofAWSS3'!G2"
    Worksheets("S3CostandUsagePretty").Range("C2").Style = "Currency"
    Worksheets("S3CostandUsagePretty").Range("D2").NumberFormat = "0.00"
    
    Worksheets("S3CostandUsagePretty").Range("A2:D2").Copy
    Worksheets("S3CostandUsagePretty").Range("A3:D" & last_row).PasteSpecial Paste:=xlPasteAll

    
    Worksheets("S3CostandUsagePretty").Range("A1:D" & last_row).Sort Key1:=Worksheets("S3CostandUsagePretty").Columns("D"), Order1:=xlDescending, Header:=xlYes
    Worksheets("S3CostandUsagePretty").Range("A1").Select
    
    Application.ScreenUpdating = True
End Sub


' Values
Sub CreatePrettyValues()
    Application.ScreenUpdating = False 'Turn screen updating off and on again to speed up programs
    Application.DisplayAlerts = False 'Turn pop ups alerts off
    
    Dim last_row As Integer
    last_row = Worksheets("Rick-MonthlyCostandUsageofAWSS3").Range("A65536").End(xlUp).Row
    
    For RowCount = 2 To last_row
    
        Sheets("S3CostandUsagePretty").Range("A" & RowCount) = Sheets("Rick-MonthlyCostandUsageofAWSS3").Range("C" & RowCount) & " - " & Sheets("Rick-MonthlyCostandUsageofAWSS3").Range("D" & RowCount)
        Sheets("S3CostandUsagePretty").Range("B" & RowCount) = Sheets("Rick-MonthlyCostandUsageofAWSS3").Range("E" & RowCount)
        Sheets("S3CostandUsagePretty").Range("C" & RowCount) = Sheets("Rick-MonthlyCostandUsageofAWSS3").Range("F" & RowCount)
        Sheets("S3CostandUsagePretty").Range("D" & RowCount) = Sheets("Rick-MonthlyCostandUsageofAWSS3").Range("G" & RowCount)
        Worksheets("S3CostandUsagePretty").Range("C" & RowCount).Style = "Currency"
        Worksheets("S3CostandUsagePretty").Range("D" & RowCount).NumberFormat = "0.00"
    
   Next RowCount
    
    Worksheets("S3CostandUsagePretty").Range("A1:D" & last_row).Sort Key1:=Worksheets("S3CostandUsagePretty").Columns("D"), Order1:=xlDescending, Header:=xlYes
    Worksheets("S3CostandUsagePretty").Range("A1").Select
  
    Application.ScreenUpdating = True
End Sub



'Code to take a data set with rows of multiple numbers of columns and stack it into a single column of data
Sub stacker()
    Application.ScreenUpdating = False
    
    Dim LastRow, RowCount, LastRow2 As Long
    LastRow = Sheets("Sheet1").Range("A65536").End(xlUp).Row
 
    For RowCount = 1 To LastRow
        Sheets("Sheet1").Select
        Range("A" & RowCount).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Sheet2").Select
        LastRow2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row + 1
        Range("A" & LastRow2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Next RowCount
       
    Application.ScreenUpdating = True
End Sub



'Example of an if-then and a clear whole page
Sub clear_page1()
 If Worksheets("Raw").Range("A4") <> "" Then
    Worksheets("Raw").Range("A4:AX" & Worksheets("Raw").Range("A65536").End(xlUp).Row).ClearContents
 End If
 Worksheets("Raw").Range("A3").Select
End Sub



'Example of sorting a range by a column...in this case J
Sub sortJ()
 Dim last_row As Integer
 last_row = Worksheets("Final").Range("A65536").End(xlUp).Row
 Worksheets("Final").Range("A3:BA" & last_row).sort Key1:=Worksheets("Final").Columns("J"), Order1:=xlDescending, Header:=xlYes
End Sub



'Example of copying and pasting
Sub copy_paste_page()
 Dim last_row As Integer
 last_row = Worksheets("Raw").Range("A65536").End(xlUp).Row
 
 'copy and paste all
 Worksheets("Clean").Range("A4:AX4").Copy
 Worksheets("Clean").Range("A5:AX" & last_row).PasteSpecial Paste:=xlPasteAll
 Worksheets("Clean").Range("A3").Select
 
 'copy and paste values and formats 
 Worksheets("Clean").Range("A4:AR" & last_row).Copy
 Worksheets("Final").Range("A4:AR" & last_row).PasteSpecial Paste:=xlPasteValues
 Worksheets("Final").Range("A4:AR" & last_row).PasteSpecial Paste:=xlPasteFormats
 Worksheets("Clean").Range("A3").Select
End Sub



'This example shows how to find the last column and row using xlUp and xlToLeft
'and how to use a 2D variant array to refer to blocks of cells
Sub arek_code()
 Dim rngDataAD, rngData4, rngData As Range, vArrayAD, vArray4, vData As Variant
 Dim i, j, k As Long
 
 Set rngDataAD = Sheets("original").Range("A5:D" & Range("D65536").End(xlUp).Row) 'the range to consider
 vArrayAD = rngDataAD.Value 'pass range values to 2D variant array
 Set rngData4 = Sheets("original").Range(Cells(4, 5), Cells(4, Range("IV4").End(xlToLeft).Column)) 'the range to consider
 vArray4 = Application.Transpose(rngData4.Value) 'pass range values to 2D variant array
 Set rngData = Sheets("original").Range(Cells(5, 5), Cells(Range("D65536").End(xlUp).Row, Range("IV4").End(xlToLeft).Column)) 'the range to consider
 vData = rngData.Value 'pass range values to 2D variant array

 For i = LBound(vArrayAD, 1) To UBound(vArrayAD, 1)
    For j = LBound(vArray4, 1) To UBound(vArray4, 1)
    k = (i - 1) * UBound(vArray4, 1) + j
    Sheets("expand").Cells(k, 1) = vArrayAD(i, 1)
    Sheets("expand").Cells(k, 2) = vArrayAD(i, 2)
    Sheets("expand").Cells(k, 3) = vArrayAD(i, 3)
    Sheets("expand").Cells(k, 4) = vArrayAD(i, 4)
    Sheets("expand").Cells(k, 5) = vArray4(j, 1)
    Sheets("expand").Cells(k, 6) = vData(i, j)
    Next j
 Next i
End Sub



 
'Putting it all together in an example
Function ColumnNumberToLetter(Clmn As Integer) As String
    If (Clmn > 26) Then
        If Clmn Mod 26 = 0 Then
            ColumnNumberToLetter = ColumnNumberToLetter(Clmn \ 26 - 1) & "Z"
        Else
            ColumnNumberToLetter = ColumnNumberToLetter(Clmn \ 26) & ColumnNumberToLetter(Clmn Mod 26)
        End If
    Else
        ColumnNumberToLetter = Chr(Asc("A") + Clmn - 1)
    End If
End Function

Sub MakeDocs()
Application.ScreenUpdating = False 'Turn off screen updating
Application.DisplayAlerts = False  'Turn off alert pop-ups
 Dim j, k As Integer
    For j = 1 To 123
     k = 2 * j
     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Doc" & j
     Sheets("Sheet1").Range(ColumnNumberToLetter(1) & "3:" & ColumnNumberToLetter(1) & "101").Copy
     Sheets("Doc" & j).Range("A1:A100").Select

     Selection.PasteSpecial
     Sheets("Sheet1").Range(ColumnNumberToLetter(k) & "3:" & ColumnNumberToLetter(k) & "101").Copy
     Sheets("Doc" & j).Range("C1:C100").Select

     Selection.PasteSpecial
     Sheets("Sheet1").Range(ColumnNumberToLetter(k + 1) & "3:" & ColumnNumberToLetter(k + 1) & "101").Copy
     Sheets("Doc" & j).Range("B1:B100").Select
     Selection.PasteSpecial
     
     Sheets("Doc" & j).Range("B1:C1").Select
     Selection.Merge
     Sheets("Doc" & j).Range("D1:E1").Select
     Selection.Merge
     Sheets("Doc" & j).Range("F1:G1").Select
     Selection.Merge

     Sheets("Doc" & j).Rows("2:2").Select
     Selection.Insert Shift:=xlDown

     'Case Select is a handy thing to know
     Dim Doc_id, Doc_grp As Integer
     Doc_id = Sheets("Sheet1").Range(ColumnNumberToLetter(k) & "2")
Select Case Doc_id
Case 1, 13, 15, 39, 145, 45, 46, 50, 61, 71, 73, 86, 89, 90, 92, 93, 99, 102, 104, 112, 115, 116, 118
Doc_grp = 1
Case 120, 4, 9, 10, 48, 77, 81, 88, 97
Doc_grp = 2
Case 6, 25, 12, 14, 17, 21, 22, 23, 24, 26, 30, 31, 33, 36, 40, 43, 47, 56, 59, 60, 65, 69, 75
Doc_grp = 3
Case 5, 16, 19, 147, 29, 55, 51, 52, 54, 58, 62, 63, 67, 84, 87, 91, 34, 110, 117, 123, 125, 37
Doc_grp = 4
Case 2, 3, 11, 18, 20, 144, 41, 49, 53, 64, 68, 72, 74, 76, 79, 83, 96, 100, 103, 106, 107, 113, 121
Doc_grp = 5
Case 28, 35, 42, 148, 66, 78, 108, 119
Doc_grp = 6
End Select

     Sheets("Groups").Range(ColumnNumberToLetter(4 * (Doc_grp - 1) + 2) & "3:" & ColumnNumberToLetter(4 * (Doc_grp - 1) + 5) & "101").Copy
     Sheets("Doc" & j).Range("D2:D100").Select
     Selection.PasteSpecial

     Dim Doc_grp_label, temp As Variant
Select Case Doc_id
Case 1, 13, 15, 39, 145, 45, 46, 50, 61, 71, 73, 86, 89, 90, 92, 93, 99, 102, 104, 112, 115, 116, 118
Doc_grp_label = "Solo1 no assoc Practice"
Case 120, 4, 9, 10, 48, 77, 81, 88, 97
Doc_grp_label = "Solo1 >25 assoc Practice"
Case 6, 25, 12, 14, 17, 21, 22, 23, 24, 26, 30, 31, 33, 36, 40, 43, 47, 56, 59, 60, 65, 69, 75
Doc_grp_label = "Solo2 no assoc Practice"
Case 5, 16, 19, 147, 29, 55, 51, 52, 54, 58, 62, 63, 67, 84, 87, 91, 34, 110, 117, 123, 125, 37
Doc_grp_label = "Solo2 >25 assoc Practice"
Case 2, 3, 11, 18, 20, 144, 41, 49, 53, 64, 68, 72, 74, 76, 79, 83, 96, 100, 103, 106, 107, 113, 121
Doc_grp_label = "Group<201 assoc Practice"
Case 28, 35, 42, 148, 66, 78, 108, 119
Doc_grp_label = "Group>200 assoc Practice"
End Select
     Sheets("Doc" & j).Range("A2") = Doc_grp_label

     Sheets("Doc" & j).Range("A1") = "Study Group 2012 Comparison of Individual Practice vs. Average and Top Tier"
     Sheets("Doc" & j).Range("A1").WrapText = True
     Sheets("Doc" & j).Range("D1") = "Practice grouping average"
     Sheets("Doc" & j).Range("F1") = "Top-tier average"
     Sheets("Doc" & j).Range("C2") = "Average Collections"
     Sheets("Doc" & j).Range("B2") = "Percent of Collections"
     Sheets("Doc" & j).Range("E2") = "Average Collections"
     Sheets("Doc" & j).Range("D2") = "Percent of Collections"
     Sheets("Doc" & j).Range("G2") = "Average Collections"
     Sheets("Doc" & j).Range("F2") = "Percent of Collections"
     Sheets("Doc" & j).Columns("B:G").HorizontalAlignment = xlCenter
     Sheets("Doc" & j).Columns(1).ColumnWidth = 40
     Sheets("Doc" & j).Columns("B:G").ColumnWidth = 17
     Sheets("Doc" & j).Rows("1").RowHeight = 70
     Sheets("Doc" & j).Rows("2").RowHeight = 40
     Sheets("Doc" & j).Range("1:2").EntireRow.Font.Bold = True
     Sheets("Doc" & j).Range("A1").Select     

     Sheets("Doc" & j).Select
     ActiveWindow.View = xlPageBreakPreview
     ActiveSheet.Range("3:200").EntireRow.AutoFit
     ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
     ActiveSheet.HPageBreaks.Add Before:=ActiveSheet.Range("A65")
     ActiveSheet.PageSetup.PrintTitleRows = "$1:$2"
     ActiveSheet.PageSetup.LeftFooter = "expenses stats"
     ActiveSheet.PageSetup.CenterFooter = "CMC Associates Confidential"
     ActiveSheet.PageSetup.RightFooter = "&P"
    Next j

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub



Back to Rick McFarland's Library

Retrieved from "https://en.wikipedia.org/w/index.php?title=User:Statsrick/VBA_code&oldid=1086843517"