User:Statsrick/VBA code

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

Content Disclaimer

Informasi ini disarikan dari Wikipedia dan disajikan kembali untuk tujuan edukasi. Konten tersedia di bawah lisensi CC BY-SA 3.0. Kami tidak bertanggung jawab atas ketidakakuratan data yang bersumber dari kontribusi publik tersebut.

  1. The information displayed on this website is sourced in part or in whole from Wikipedia and has been adapted for the purpose of restating it. We strive to provide accurate and relevant information, however:
  2. There is no guarantee of absolute accuracy. Wikipedia is an open, collaborative project that can be edited by anyone, so information is subject to change.
  3. It is not intended to constitute professional advice. The content displayed is for informational and educational purposes only. For important decisions (e.g., medical, legal, or financial), please consult a professional.
  4. Content copyright. Wikipedia is licensed under the Creative Commons Attribution-ShareAlike License (CC BY-SA). This means that content may be reused with appropriate attribution and shared under a similar license.
  5. Responsible use. Any risk arising from the use of information from this website is entirely the responsibility of the user.