Cleaning up VBA Code

[Glasgowsmile]

Good Evening,

I have my coding complete, it works but it's a little sluggish and slow. I'm thinking it could be improved so I wanted to share in case anyone is able to assist in the clean up.

Thanks!

Sub FuturePDI()

   Sheets("Property Segment Data").Range("B2:I18").Clear
   Sheets("Property Segment Data").Range("N4:AC18").Clear
   Sheets("Property Segment Data").Range("B21:I34").Clear
   Sheets("Property Segment Data").Range("N21:AC34").Clear
   Sheets("Property Segment Data").Range("B37:I50").Clear
   Sheets("Property Segment Data").Range("N37:AC50").Clear
   Dim wkbCrntWorkBook As Workbook
   Dim wkbSourceBook As Workbook
   Set wkbCrntWorkBook = ActiveWorkbook
   With Application.FileDialog(msoFileDialogOpen)
      .Filters.Clear
      .Filters.Add "Excel 2007-13", "*.xlsx; *.xls; *.xlsm; *.xlsa"
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count > 0 Then
         Workbooks.Open .SelectedItems(1)
         Set wkbSourceBook = ActiveWorkbook
         Sheets("Property Segment Data").Range("B2:I18").Copy
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("B2").PasteSpecial xlPasteValues
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("B2").PasteSpecial xlPasteFormats
         
         Sheets("Property Segment Data").Range("N4:AC18").Copy
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("N4").PasteSpecial xlPasteValues
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("N4").PasteSpecial xlPasteFormats
         
         Sheets("Property Segment Data").Range("B21:I34").Copy
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("B21").PasteSpecial xlPasteValues
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("B21").PasteSpecial xlPasteFormats
         
         Sheets("Property Segment Data").Range("N21:AC34").Copy
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("N21").PasteSpecial xlPasteValues
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("N21").PasteSpecial xlPasteFormats
         
         Sheets("Property Segment Data").Range("B37:I50").Copy
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("B37").PasteSpecial xlPasteValues
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("B37").PasteSpecial xlPasteFormats
         
         Sheets("Property Segment Data").Range("N37:AC50").Copy
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("N37").PasteSpecial xlPasteValues
         wkbCrntWorkBook.Sheets("Property Segment Data").Range("N37").PasteSpecial xlPasteFormats
         
         wkbSourceBook.Close False
      End If
   End With
      Columns("A").EntireColumn.Hidden = True
      Rows("1").EntireRow.Hidden = True
      Columns("B").ColumnWidth = 23
      Columns("C").ColumnWidth = 28
      Columns("N").ColumnWidth = 28
      Columns("D:L").ColumnWidth = 11
      Columns("O:AC").ColumnWidth = 11
End Sub

 

[tonyyy]

Glasgowsmile,

You might want to check out Chip Pearson's Optimizing VBA tips.

Cheers,

tonyyy

 

[dmt32]

Hi,
untested but see if this update to your code helps

Sub FuturePDI()
    Dim wsPropertySegmentData As Worksheet
    Dim wkbSourceBook As Workbook
    Dim PasteCopyRange As Range, Area As Range
    Dim FileName As String
    
    Set wsPropertySegmentData = ThisWorkbook.Worksheets("Property Segment Data")
    
    Set PasteCopyRange = wsPropertySegmentData.Range("B2:I18,N4:AC18,B21:I34,N21:AC34,B37:I50,N37:AC50")
    
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel 2007-13", "*.xlsx; *.xls; *.xlsm; *.xlsa"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        FileName = .SelectedItems(1)
    End With
    
    On Error GoTo myerror
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
    End With
    
    PasteCopyRange.Clear
    
    Set wkbSourceBook = Workbooks.Open(FileName, , True)
    
    For Each Area In PasteCopyRange.Areas
        wkbSourceBook.Sheets("Property Segment Data").Range(Area.Address).Copy
        With Area.Cells(1, 1)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
'clear clipboard
        Application.CutCopyMode = False
    Next Area
            
        wkbSourceBook.Close False
            
            
        Columns("A").EntireColumn.Hidden = True
        Rows("1").EntireRow.Hidden = True
        Columns("B").ColumnWidth = 23
        Columns("C").ColumnWidth = 28
        Columns("N").ColumnWidth = 28
        Columns("D:L").ColumnWidth = 11
        Columns("O:AC").ColumnWidth = 11
            
myerror:
        With Application
            .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic
        End With
        If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave