Excel program crashes

[dshafique]

Hi guys, I have this macro which checks against the date and name of today's data in yesterday's data, and then copies over all the rows that have match the criteria. Problem is that there are about 67000+ lines, and Its been running format least 2 hours right now. Is there a way for it to be faster? Or am I doomed to crash

 

[Fluff]

Could you post the code that you're using?

 

[Joe4]

If you post your VBA code, we may be able to see if there are ways to write it to make it more efficient.

However, I will say this. If you are comparing two large lists of data to look for matches (or unmatched data), I personally would choose to use Access to do this. I think it handles it a bit better, as it is a relational database program.

 

[dshafique]

the data is updated everyday, it compares today and yesterday and spits out any data that is the same date and name in both sheets, so then the user than see if anything changed. there are a bunch of columns with different data, but the users just want to be able to see if anyone's access level or soemthing changed each day. at the end of the macros, i have it so it adds an extra empty row after each unique name, so the users can see clearly.

Sub Structure()
'
' Macro2 Macro
'
   Dim tbl As ListObject
    Dim rng As Range
     Dim iRow As Integer, iCol As Integer
    Dim oRng As Range
    
    
    Sheets("Today").Select
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(18, 1), Array(29, 1), Array(36, 1), Array(53, 1), _
        Array(67, 1), Array(78, 1), Array(92, 1), Array(95, 1), Array(101, 1), Array(113, 1), Array _
        (119, 1)), TrailingMinusNumbers:=True
        
        


    Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.Name = "tTable"
    tbl.TableStyle = "TableStyleLight8"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "=WORKDAY(R[-2]C,-1)"
    Range("A4").Select
    Selection.NumberFormat = "m/d/yyyy"
    ActiveSheet.ListObjects("tTable").Range.AutoFilter Field:=12, Criteria1:=Range("A4").Value
   
    Columns("D:D").ColumnWidth = 20
    Range("A1").Select
    Range("tTable[[#Headers],[Column12]]").Select
    ActiveCell.FormulaR1C1 = "Last Maintainence Date"
    Range("tTable[[#Headers],[Column11]]").Select
    ActiveCell.FormulaR1C1 = "OD"
    Range("tTable[[#Headers],[Column10]]").Select
    ActiveCell.FormulaR1C1 = "VCR"
    Range("tTable[[#Headers],[Column9]]").Select
    ActiveCell.FormulaR1C1 = "TAR"
    Range("tTable[[#Headers],[Column7]]").Select
    ActiveCell.FormulaR1C1 = "SOR"
    Range("tTable[[#Headers],[Column6]]").Select
    ActiveCell.FormulaR1C1 = "DCR"
    Range("tTable[[#Headers],[Column4]]").Select
    ActiveCell.FormulaR1C1 = "Name"
    Range("tTable[[#Headers],[Column3]]").Select
    ActiveCell.FormulaR1C1 = "INIT"
    Range("tTable[[#Headers],[Column2]]").Select
    ActiveCell.FormulaR1C1 = "ID"
    Range("tTable[[#Headers],[Column1]]").Select
    ActiveCell.FormulaR1C1 = "Region"
    
    
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    Worksheets.Add(After:=Worksheets(Sheets.Count)).Name = "Data"
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
    Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.Name = "dTable"
    tbl.TableStyle = "TableStyleLight8"
    
    
    
    
    Sheets("Yesterday").Select
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(18, 1), Array(29, 1), Array(36, 1), Array(53, 1), _
        Array(67, 1), Array(78, 1), Array(92, 1), Array(95, 1), Array(101, 1), Array(113, 1), Array _
        (119, 1)), TrailingMinusNumbers:=True
        


    Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.Name = "yTable"
    tbl.TableStyle = "TableStyleLight8"
    
    Columns("D:D").ColumnWidth = 20
    Range("A1").Select
    Range("yTable[[#Headers],[Column12]]").Select
    ActiveCell.FormulaR1C1 = "Last Maintainence Date"
    Range("yTable[[#Headers],[Column11]]").Select
    ActiveCell.FormulaR1C1 = "OD"
    Range("yTable[[#Headers],[Column10]]").Select
    ActiveCell.FormulaR1C1 = "VCR"
    Range("yTable[[#Headers],[Column9]]").Select
    ActiveCell.FormulaR1C1 = "TAR"
    Range("yTable[[#Headers],[Column7]]").Select
    ActiveCell.FormulaR1C1 = "SOR"
    Range("yTable[[#Headers],[Column6]]").Select
    ActiveCell.FormulaR1C1 = "DCR"
    Range("yTable[[#Headers],[Column4]]").Select
    ActiveCell.FormulaR1C1 = "Name"
    Range("yTable[[#Headers],[Column3]]").Select
    ActiveCell.FormulaR1C1 = "INIT"
    Range("yTable[[#Headers],[Column2]]").Select
    ActiveCell.FormulaR1C1 = "ID"
    Range("yTable[[#Headers],[Column1]]").Select
    ActiveCell.FormulaR1C1 = "Region"
    
    
    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "Status"
    ActiveCell.Offset(1).Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(IF(MATCH(RC[-9],dTable[Name],0),""yes"",),""no"")"
    ActiveCell.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False


    If Application.CountIf(ActiveSheet.ListObjects("yTable").ListColumns("Status").DataBodyRange, "yes") Then
          ActiveSheet.ListObjects("yTable").Range.AutoFilter Field:=13, Criteria1:= _
        "yes"
        Columns("M:M").Select
    Selection.EntireColumn.Hidden = True
   ActiveWorkbook.Worksheets("Yesterday").ListObjects("yTable").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Yesterday").ListObjects("yTable").Sort.SortFields. _
        Add Key:=Range("yTable[[#All],[Name]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Yesterday").ListObjects("yTable").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        Sheets("Data").Select
        Range("A1").Select
        Selection.End(xlDown).Select
        ActiveSheet.ListObjects("dtable").ListRows.Add AlwaysInsert:=True
        Sheets("Yesterday").Select
        Range("A1").Select
        ActiveSheet.ListObjects("yTable").DataBodyRange.Select


        Selection.Copy
        Sheets("Data").Select
        Range("A1").Select
        Selection.End(xlDown).Select
        
       ActiveCell.Offset(1).Select
        ActiveSheet.Paste
        
 
        
        
        Range("A1").Select
        
        
      
 
 ActiveWorkbook.Worksheets("Data").ListObjects("dTable").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").ListObjects("dTable").Sort.SortFields.Add _
        Key:=Range("dTable[[#All],[Name]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").ListObjects("dTable").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
 
Else: Sheets("Data").Select
End If
Range("A1").Select


Set oRng = Range("D1")


iRow = oRng.Row
iCol = oRng.Column


Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""


'
Range("A1").Select
Columns("D:D").ColumnWidth = 20
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Range("A1").Select




Columns.EntireColumn.AutoFit
Range("A1").Select
sFName = Application.GetSaveAsFilename
If sFName <> "False" Then ActiveWorkbook.SaveAs sFName
    
    
End Sub

 

[Joe4]

Here are two tips which should help your performance greatly:

1. It is usually not necessary to select cells in order to work with them in VBA.
Selecting cells is usually unnecessary, and actually slows down your code. So if you can remove most of your Selects, you can increase the performance of your code.
The Macro Recorder is very literal, and when you record code, it has all the Selects in there that can usually be cleaned up and eliminated.

So to do that, if you have a block like this:

Range("tTable[[#Headers],[Column7]]").Select
ActiveCell.FormulaR1C1 = "SOR"

where one line ends in "Select", and the next begins with "Selection" or "ActiveCell", you can combine those two lines like this:

Range("tTable[[#Headers],[Column7]]").FormulaR1C1 = "SOR"

So, there are a lot of places in your code where you can do this.

2. The other thing you can do to help code performance is to disable the screen updates until the end. In order to do that, place this line at the very beginning of your code:

Application.ScreenUpdating = False

and then turn it back on at the very end of your code like this:

Application.ScreenUpdating = True

I am sure that there are probably other things you can do to speed up your code, but these are two common ones that should help give you some big bang for your buck.