VBA Running Very Slowly

[nickshep85]

I have the below code as part of a macro, which I use to import rows of data from one workbook and put them into one of three tabs. This used to import into two tabs until the number of rows increased, so I'm assuming that one of the changes I have made is causing this code to run slowly.

The bold code is the part that I have added in recently.

Can someone please help me figure out what is causing this code to run so slowly. I used to be able to import and sort 70,000 rows in 10 minutes, but I had to force break this code after an hour.

  Workbooks("PriceFile.xls").Activate
  
    m = 3
    n = 3
    t = 3

    For i = 1 To Workbooks("PriceFile.xls").Sheets.Count
        Worksheets(i).Select
        Range("A1").Select
        Selection.End(xlDown).Select
        End_Row = ActiveCell.Row
        l = 1
        
        
        Do Until l = End_Row
        
[B]       
        If Workbooks("Importfile.xls").Worksheets("Mechanical").UsedRange.Rows.Count > 65534 Then
        If Cells(i, 9).Value = "True" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Mechanical2").Select
                Cells(m, 1).Select
                ActiveSheet.Paste
                m = m + 1
            End If
            Else
        ' ^^^ Used to be End If[/B]
        If Cells(l, 9).Value = "True" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Mechanical").Select
                Cells(n, 1).Select
                ActiveSheet.Paste
                n = n + 1
            End If
            If Cells(l, 9).Value = "False" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Tyres").Select
                Cells(t, 1).Select
                ActiveSheet.Paste
                t = t + 1
            End If
            Workbooks("PriceFile.xls").Activate
            Worksheets(i).Select
            l = l + 1
            End If
        Loop
      
    Next i

 

[Tinbendr]

This needs to be rewitten to eliminate select/activate. Those are your bottleneck.

Can you tell us a little move about the data and where is going. It's testing for cells(i,9); what is that exactly.

Oh, and go to your profile and add your version so we don't have to guess.

 

[nickshep85]

Thanks for your reply,

I am very new with VBA and so am struggling to put together lots of code that I have gathered from various sources.

I am running Excel 2003 on XP.


Basically, I am importing a text file into "Pricefile.xls". The text file now has 90000+ rows and is imported into as many sheets as is necessary. I then add a formula into Column I which will give me a TRUE / FALSE result.

I then need to import the rows of data from "Pricefile.xls" into "ImportFile.xls", separating out the TRUE and FALSE valued rows into different tabs. (TRUE into "Mechanical" and FALSE into "Tyres")
This was working fine when there were 70000 total rows and only 50000 would go into the "Mechanical" tab, but now that my text file has increased in size, there are more than 65000 rows to be imported into one tab. I updated the code to insert a new sheet, "Mechanical2", to continue importing data into. However, somewhere along the line this has caused a huge slow down.

Below is the full code that I use to transfer the data from one workbook to the other. Any help would be much appreciated as I have been struggling through this for hours now.

Sub Transfer_Data()
Dim End_Row As Long

   

'Add New Workbook
Workbooks.Add template:=xlWorksheet

      Dim mypath As String
      mypath = ThisWorkbook.Path

'Add New Sheet and Overwrite Last File
ActiveWorkbook.Sheets.Add
ActiveWorkbook.Sheets.Add
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs (mypath & "/ImportFile.xls")
    Application.DisplayAlerts = True
    
'Name Sheets
Sheets("Sheet1").Name = "Tyres"
Sheets("Sheet2").Name = "Mechanical"
Sheets("Sheet3").Name = "Mechanical2"

'Add Title and Date into Both Sheets
Dim wksh As Worksheet
On Error Resume Next
For Each wksh In Worksheets
    With wksh
    .Range("A1").FormulaR1C1 = "=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-5)"

    .Range("B1").FormulaR1C1 = "=today()"
    .Range("B1").Select

    .Range("B1").Copy
    .Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Application.Goto Reference:="R1C1"
    .Application.CutCopyMode = False
    
    'Add Headers into both Sheets
    .Range("A2").Value = "CODE"
    .Range("B2").Value = "DESCRIPTION"
    .Range("C2").Value = "XXX"
    .Range("D2").Value = "XXX"
    .Range("E2").Value = "XXX"
    .Range("F2").Value = "XXX"
    .Range("G2").Value = "PRICE"
    .Range("H2").Value = "XXX"
    .Range("I2").Value = "XXX"
  
    End With
    
    Next wksh
    
    'Format Both Sheets
    Sheets.Select
    Range("A1:I2").Select
    With Selection
      .Font.Size = 14
      .Font.Bold = True
      .Font.Color = vbWhite
      .Interior.Color = vbBlue
    End With
    
    Range("A1").Select
    Sheets("Tyres").Activate

  Workbooks("PriceFile.xls").Activate
  
    m = 3
    n = 3
    t = 3

    For i = 1 To Workbooks("PriceFile.xls").Sheets.Count
        Worksheets(i).Select
        Range("A1").Select
        Selection.End(xlDown).Select
        End_Row = ActiveCell.Row
        l = 1
        
        
        Do Until l = End_Row
        
       
        If Workbooks("Importfile.xls").Worksheets("Mechanical").UsedRange.Rows.Count > 65534 Then
        If Cells(l, 9).Value = "True" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Mechanical2").Select
                Cells(m, 1).Select
                ActiveSheet.Paste
                m = m + 1
            End If
            Else
        ' ^^^ Used to be End If
        If Cells(l, 9).Value = "True" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Mechanical").Select
                Cells(n, 1).Select
                ActiveSheet.Paste
                n = n + 1
            End If
            If Cells(l, 9).Value = "False" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Tyres").Select
                Cells(t, 1).Select
                ActiveSheet.Paste
                t = t + 1
            End If
            Workbooks("PriceFile.xls").Activate
            Worksheets(i).Select
            l = l + 1
            End If
        Loop
      
    Next i
    

Workbooks("ImportFile").Activate
Dim wksht As Worksheet
On Error Resume Next
For Each wksht In Worksheets
With wksht

.Range("H:I").Delete
.Range("C:F").Delete

.Cells.Select
.Cells.EntireColumn.AutoFit

.Range("C:C").NumberFormat = "£#,##0.00"

.Range("B1").HorizontalAlignment = xlCenter
.Range("C1").Select

End With
Next wksht

Sheets.Select
Range("C1").Select
Sheets("Mechanical").Select
Sheets("Mechanical").Activate

Workbooks("ImportFile").Activate

    fname = Application.GetSaveAsFilename(filefilter:="Excel Files (*.xls), *.xls")

ActiveWorkbook.SaveAs FileName:=fname, FileFormat:=xlNormal



End Sub

 

[Tinbendr]

What about multiple groups? Col 1-9, Col 10-19, etc?

What are you using this for? Do you need ready access to the data in Import? If you're just occasionally going out to the price list to get data, you could fetch it using a query.

 

[p45cal]

There are going to be much more efficient ways of doing this (autofiltering, or setting up query on the original text file) than my suggestion below, but since I have little idea of your setup I have concentrated only on speeding up existing code, and only that bit which has lots of iterations. Try replacing your code bit:

m = 3
n = 3
t = 3
For i = 1 To Workbooks("PriceFile.xls").Sheets.Count
  Worksheets(i).Select
  Range("A1").Select
  Selection.End(xlDown).Select
  End_Row = ActiveCell.Row
  l = 1
  Do Until l = End_Row
    If Workbooks("Importfile.xls").Worksheets("Mechanical").UsedRange.Rows.Count > 65534 Then
      If Cells(l, 9).Value = "True" Then
        Rows(l).Copy
        Workbooks("ImportFile.xls").Activate
        Worksheets("Mechanical2").Select
        Cells(m, 1).Select
        ActiveSheet.Paste
        m = m + 1
      End If
    Else
      ' ^^^ Used to be End If
      If Cells(l, 9).Value = "True" Then
        Rows(l).Copy
        Workbooks("ImportFile.xls").Activate
        Worksheets("Mechanical").Select
        Cells(n, 1).Select
        ActiveSheet.Paste
        n = n + 1
      End If
      If Cells(l, 9).Value = "False" Then
        Rows(l).Copy
        Workbooks("ImportFile.xls").Activate
        Worksheets("Tyres").Select
        Cells(t, 1).Select
        ActiveSheet.Paste
        t = t + 1
      End If
      Workbooks("PriceFile.xls").Activate
      Worksheets(i).Select
      l = l + 1
    End If
  Loop
Next i

with this:

Set MechDestSht = Workbooks("ImportFile.xls").Worksheets("Mechanical")
n = 3
t = 3
For Each sht In Workbooks("PriceFile.xls").Sheets
  With sht
    End_Row = .Range("A1").End(xlDown).Row
    For l = 1 To End_Row
      If .Cells(l, 9).Value = "True" Then
        If n > 65530 Then
          Set MechDestSht = Workbooks("ImportFile.xls").Worksheets("Mechanical2")
          n = 3
        End If
        .Rows(l).Copy MechDestSht.Rows(n)
        n = n + 1
      Else
        If .Cells(l, 9).Value = "False" Then
          .Rows(l).Copy Workbooks("ImportFile.xls").Worksheets("Tyres").Rows(t)
          t = t + 1
        End If
      End If
    Next l
  End With  'sht
Next sht

(untested)

 

[nickshep85]

P45cal, this is brilliant, it's cut down the run time even with 20000 extra rows.

Looking at your code, I can manage to see how some of this works, but some of it loses me completely. It appears I still have a LOT to learn about VBA.

Thank you so much for your help.

 

[excel_help_101]

not sure if this will help you or not but it takes a lot of time to do the screen updates put this at the start and end of your code
Application.ScreenUpdating</SPAN> = False </SPAN>
Application.ScreenUpdating</SPAN> = True</SPAN>
you will not see the code running any more
this helped me alot with speeding up a macro's run time