Help Cleaning Up Code

Status
Not open for further replies.
L

Lelewiwi

Board Regular
Joined
Nov 8, 2023
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Below is code that I have inherited. I am not a coder. It is extremely slow and clunky from what I can tell. The number of rows in the original text file can vary. Is there a way to clean this up?

This is what the original text file looks like:
Screenshot 2024-01-03 080743.jpg


VBA Code: 
Sub Macro1()

Dim strFile As String
Dim wb As Workbook
Dim ws As Worksheet

Set ws = ActiveSheet

'Choose text file to import
MsgBox "Please select a text file", vbOKOnly
strFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")

If strFile = "False" Then Exit Sub

With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
    .TextFileParseType = xlDelimited
    .TextFileCommaDelimiter = False
    .Refresh
End With

' create new cols for data
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").FormulaR1C1 = "Data"
    Range("B1").FormulaR1C1 = "Acct#"
    Range("C1").FormulaR1C1 = "Account"
    Range("D1").FormulaR1C1 = "Mo"
    Range("E1").FormulaR1C1 = "Month"
    Range("F1").FormulaR1C1 = "Amt"
    Range("G1").FormulaR1C1 = "Amt1"
    Range("H1").FormulaR1C1 = "Amount"
    
' extract data to new cols
    Range("B2").FormulaR1C1 = "=MID(RC[-1],18,6)"
    Range("C2").FormulaR1C1 = "=VALUE(RC[-1])"
    Range("D2").FormulaR1C1 = "=MID(RC[-3],14,4)"
    Range("E2").FormulaR1C1 = "=DATE(""20""&RIGHT(RC[-1],2),LEFT(RC[-1],2),""01"")"
    Range("F2").FormulaR1C1 = "=RIGHT(RC[-5],5)"
    Range("G2").FormulaR1C1 = "=CONCAT(LEFT(RC[-1],3),""."",RIGHT(RC[-1],2))"
    Range("H2").FormulaR1C1 = "=SUBSTITUTE(RC[-1],""0-"",""-"")+0"
    
' populate data
    Range("B2:H2").Select
    Selection.AutoFill Destination:=Range("B2:H75000")
    
' paste acct#'s to new wksheet "First Split"
    Columns("C:C").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "First Split"
    Sheets("First Split").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
' clean up acct#'s + populate Amounts
    ActiveSheet.Range("$A$1:$A$75000").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("B1").FormulaR1C1 = "Amount"
    Range("B2").FormulaR1C1 = "=SUMIF(Sheet1!R1C3:R75000C8,'First Split'!RC[-1],Sheet1!R1C8:R75000C8)"
    Range("B2").Select
    Selection.AutoFill Destination:=Range("B2:B38")
    Range("B2:B38").Select
    
' paste acct#'s & months to new wksheet "Month Splits" + clean up data
    Range("B1").Select
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet3").Name = "Month Splits"
    Range("A1").FormulaR1C1 = "Account"
    Range("B1").FormulaR1C1 = "Month"
    Range("C1").FormulaR1C1 = "Amount"
    Range("A2").Select
    Sheets("Sheet1").Select
    Range("C1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Month Splits").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("B2").Select
    Sheets("Sheet1").Select
    Range("E1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Month Splits").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("B3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "m/d/yyyy"
    Columns("A:B").Select
    ActiveSheet.Range("$A$1:$B$75000").RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    
' populate data
    Range("C2").FormulaR1C1 = "=SUMIFS(Sheet1!R2C8:R75000C8,Sheet1!R2C3:R75000C3,'Month Splits'!RC[-2],Sheet1!R2C5:R75000C5,'Month Splits'!RC[-1])"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C75000")
    Range("C2:C75000").Select

' Add Sheet
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet4").Name = "Manual Adjustments"
    Sheets("Manual Adjustments").Select

Dim r1, r2
'Determine that last row in the Data Sheet (r1)
Sheets("Sheet1").Select
r1 = Range("A75000").End(xlUp).Row

'Export manual adjustments
Dim count As Long
For count = 2 To r1
    If Range("H" & count).Value < 0 Then
        Rows(count).EntireRow.Cut
        'Determine that last row in the Manual Adjustments Sheet (r2)
        Sheets("Manual Adjustments").Select
        r2 = Range("A75000").End(xlUp).Row
        Rows(r2 + 1).EntireRow.Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
    End If
Next count

On Error Resume Next
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Sheets("Manual Adjustments").Select

Dim sourceWs As Worksheet
Dim newWb As Workbook
Dim wsName As String

Set sourceWs = ThisWorkbook.Sheets("Manual Adjustments")

wsName = "Annuity Adjustments"

' create new cols for data
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").FormulaR1C1 = "Data"
    Range("B1").FormulaR1C1 = "Acct#"
    Range("C1").FormulaR1C1 = "Account"
    Range("D1").FormulaR1C1 = "Mo"
    Range("E1").FormulaR1C1 = "Month"
    Range("F1").FormulaR1C1 = "Amt"
    Range("G1").FormulaR1C1 = "Amt1"
    Range("H1").FormulaR1C1 = "Amount"

sourceWs.Copy
Application.DisplayAlerts = False
sourceWs.Delete
Application.DisplayAlerts = True

Set newWb = ActiveWorkbook

newWb.Sheets(1).Name = wsName

'Save manual adjustments
MsgBox "Save As 'Manual Adjustments'", vbOKOnly
Dim File_Name As String
File_Name = Application.GetSaveAsFilename
ActiveWorkbook.SaveAs Filename:=File_Name & "xlsx"

Windows("Text File Processing.xlsm").Activate
Sheets("Sheet1").Select
Range("A1").Select

Set wb = ThisWorkbook
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Select

Dim lr As Long, lr2 As Long
Application.ScreenUpdating = False

'Find last row with data in column H
    lr = Cells(Rows.count, "H").End(xlUp).Row

'Hide all rows not equal to zero
    Columns("H:H").AutoFilter
    ActiveSheet.Range("$H$1:$H$" & lr).AutoFilter Field:=1, Criteria1:="0"

'Find last row in column H with data after filter
    lr2 = Cells(Rows.count, "H").End(xlUp).Row

'Exit sub if no data to delete data (only header visible)
    If lr2 = 2 Then Exit Sub

'Delete unhidden data
    Application.DisplayAlerts = False
    ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.count - 1).Rows.Delete
    Application.DisplayAlerts = True

'Remove filter
    Range("H1").AutoFilter

    Application.ScreenUpdating = True

Set wb = ThisWorkbook
wb.Sheets("Sheet1").Select
Dim FileSaveName As Variant

FileSaveName = Application.GetSaveAsFilename(fileFilter:="Text (Tab delimited) (*.txt), *.txt")

'Copy worksheet to new book
Sheets("Sheet1").Copy
Set wb = ActiveWorkbook
Set ws = ActiveSheet

With wb
    'Delete rows with blanks in Columns A and B
    'Then Clear All Columns but Column A
    With ws
        .Range("A:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Range(.Cells(1, "B"), .Cells(.Rows.count, .Columns.count)).Clear
        .Range(.Cells(1, "C"), .Cells(.Rows.count, .Columns.count)).Clear
        .Range(.Cells(1, "D"), .Cells(.Rows.count, .Columns.count)).Clear
        .Range(.Cells(1, "E"), .Cells(.Rows.count, .Columns.count)).Clear
        .Range(.Cells(1, "F"), .Cells(.Rows.count, .Columns.count)).Clear
        .Range(.Cells(1, "G"), .Cells(.Rows.count, .Columns.count)).Clear
        .Range(.Cells(1, "H"), .Cells(.Rows.count, .Columns.count)).Clear
    End With
    .SaveAs FileSaveName, xlTextWindows
    .Close False
End With

ThisWorkbook.Activate

' Add Sheet
    Sheets("Month Splits").Select
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet5").Name = "Money Transfer"
    Sheets("Money Transfer").Select

'Set Up Sheet
Range("1:1,3:3,4:4,5:5,6:6").Select
    Range("A6").Activate
    With Selection.Font
        .Name = "Calibri"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A1").FormulaR1C1 = "Pacific Coast Benefit Trust UPS ACH Split Request"
    Range("A3").FormulaR1C1 = "Requested By:"
    Range("A4").FormulaR1C1 = "Request Date:"
    Range("A5").FormulaR1C1 = "Postmark Date:"
    Columns("A:A").Select
    Selection.ColumnWidth = 8
    Range("A7").FormulaR1C1 = "Acct #"
    Range("B7").FormulaR1C1 = "Bill Period"
    Range("C7").FormulaR1C1 = "Amount"
    Range("E7").FormulaR1C1 = "Accounts/First Split"
    Range("E8").FormulaR1C1 = "Acct #"
    Range("F8").FormulaR1C1 = "Total"
    Range("H8").FormulaR1C1 = "Comparison"
    Columns("D:D").Select
    Selection.ColumnWidth = 2
    Columns("G:G").Select
    Selection.ColumnWidth = 2
    Range("E3").FormulaR1C1 = "Deposit Date:"
    Range("E4").FormulaR1C1 = "Deposit Amount:"
    Range("E5").FormulaR1C1 = "Accts Split Total:"
    Columns("I:I").Select
    Selection.ColumnWidth = 2
    Range("A1,A3,A4,A5,E3,E4,E5,A7,B7,C7,E7,E8,F8,H8").Select
    Range("H8").Activate
    Selection.Font.Bold = True
    Range("B3").Select
    
    Columns("B:B").Select
    Selection.ColumnWidth = 10
    Columns("C:C").Select
    Selection.ColumnWidth = 13
    Columns("E:F").Select
    Selection.ColumnWidth = 9
    Columns("H:H").Select
    Selection.ColumnWidth = 12
    Range("A7").Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A7:C7").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:I1").Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("C3:D3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("C4:D4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("C5:D5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("G3:I3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("H4:I4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("H5:I5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("E7:F7").Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("E8:H8").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A:A,E:E").Select
    Range("E1").Activate
    Selection.NumberFormat = "@"
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:I1").Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A7").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("B:B").Select
    Selection.NumberFormat = "mm-yy"
    Range("E7:F7").Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("E8").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("C:C,F:F,H:H").Select
    Range("H1").Activate
    Selection.NumberFormat = "$#,##0.00_);($#,##0.00)"
    Range("C3:D5").Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("G3:I3").Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("H4:I5").Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("E9").FormulaR1C1 = "129113"
    Range("E10").FormulaR1C1 = "129114"
    Range("E11").FormulaR1C1 = "129253"
    Range("E12").FormulaR1C1 = "129253"
    Range("E13").FormulaR1C1 = "129259"
    Range("E14").FormulaR1C1 = "129260"
    Range("E15").FormulaR1C1 = "129262"
    Range("E16").FormulaR1C1 = "129269"
    Range("E17").FormulaR1C1 = "129279"
    Range("E18").FormulaR1C1 = "129280"
    Range("E19").FormulaR1C1 = "129281"
    Range("E20").FormulaR1C1 = "129283"
    Range("E21").FormulaR1C1 = "129285"
    Range("E22").FormulaR1C1 = "129286"
    Range("E23").FormulaR1C1 = "129288"
    Range("E24").FormulaR1C1 = "129291"
    Range("E25").FormulaR1C1 = "129293"
    Range("E26").FormulaR1C1 = "129298"
    Range("E27").FormulaR1C1 = "129302"
    Range("E28").FormulaR1C1 = "129304"
    Range("E29").FormulaR1C1 = "129305"
    Range("E30").FormulaR1C1 = "129308"
    Range("E31").FormulaR1C1 = "129315"
    Range("E32").FormulaR1C1 = "129316"
    Range("E33").FormulaR1C1 = "129319"
    Range("E34").FormulaR1C1 = "129323"
    Range("E35").FormulaR1C1 = "129324"
    Range("E36").FormulaR1C1 = "129326"
    Range("E37").FormulaR1C1 = "129332"
    Range("E38").FormulaR1C1 = "129359"
    Range("E39").FormulaR1C1 = "129403"
    Range("E40").FormulaR1C1 = "129405"
    Range("E41").FormulaR1C1 = "129465"
    Range("E42").FormulaR1C1 = "129485"
    Range("E43").FormulaR1C1 = "129500"
    Range("E44").FormulaR1C1 = "129511"
    Range("E45").FormulaR1C1 = "129545"
    Range("E46").FormulaR1C1 = "129542"
    Range("E47").FormulaR1C1 = "129543"
    Range("E48").FormulaR1C1 = "129544"
    Range("E49").FormulaR1C1 = "Total:"
    Range("E49").Select
    Selection.Font.Bold = True
    Range("E9:F49").Select
    Range("F49").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("H9:H49").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("H8").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("E7:F7").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("E8:F8").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A7:C7").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

End Sub
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
There are a few "tricks" you can use to help speed up your code.

One, is to eliminate many "Select" statements. Most of the time, it is not necessary to select Ranges in order to work with them. A lot of these are the result of recorded VBA code, which is very literal. Selecting ranges slows your code down. Most any time you have one line ending in "Select", and the next line beginning with "Selection", you can combine those lines.

So a section like this:
Rich (BB code): 
    Range("C:C,F:F,H:H").Select
    Range("H1").Activate
    Selection.NumberFormat = "$#,##0.00_);($#,##0.00)"
    Range("C3:D5").Select
    With Selection.Font
can be simplified to:
Rich (BB code): 
    Range("C:C,F:F,H:H").NumberFormat = "$#,##0.00_);($#,##0.00)"
    With Range("C3:D5").Font

You can see there are two distinct sections that I reduced down.
There are lots of other places in your code that you can do this to.

Also, if you suppress Screen Updating at the very beginning of your code, until the end of the code, your code will be faster.
So put this line at the very top after your "Sub Macro1" line:
VBA Code: 
Application.ScreenUpdating = False
and then place this line of code just before your "End Sub" line:
VBA Code: 
Application.ScreenUpdating = True

Making those changes should help speed up just about any code.
 
Upvote 0
Duplicate of this thread. Please do not post the same question more than once. This is now closed.
 
Upvote 0
Status
Not open for further replies.

Similar threads

K
  • Solved
formating question
Replies
3
Views
76
Micron
M
P
  • Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
191
6StringJazzer
6StringJazzer
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
872
kerm007
K
J
  • Question
Issue with Macros and renaming files
Replies
6
Views
507
kevin9999
K
J
  • Question
VBA Code to Add Rows is slowing down
Replies
5
Views
522
JayB0730
J

Forum statistics

Threads
1,215,071
Messages
6,122,963
Members
449,094
Latest member
Anshu121

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top