同样的代码运行多次竟然时间差距十几倍？

「已注销」 2020-05-26 10:25:23

一个读取数据作图的宏。对同样的9个文件进行处理，刚开始一分钟或者三四分钟就能跑完，多run几次十几分钟下不来，后来甚至一个小时跑不完。
什么情况。

Public FC As Integer    'count for txt files

Public f As Variant

Public fcsv(10) As String

Public ind(10) As String

Public data(1 To 10, 1 To 4000) As String





Sub RTD()

Dim tm

tm = Now()

    

    'On Error Resume Next

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    

    'clear contents

    Sheets("Charts").Activate

    Range(Cells(1, 2), Cells(4100, 100)).Select

    Selection.ClearContents

    

    'clear charts

    Dim b As ChartObject

    For Each b In ActiveSheet.ChartObjects

    b.Delete

    Next



    'get csv files name

    MsgBox "Compare the same station for different tools", 0, "Open file"

    

    'Get path/name of the response *.csv file

    f = Application.GetOpenFilename("Excel Files (*.csv), *.csv", 1, "Open csv files", "Oppp", True)

    

    FC = UBound(f)

    

    If FC = 1 Or FC > 10 Then

    MsgBox "Number of files should be less than or equal to 10 and greater than or equal to 2"

    Exit Sub

    End If



    'Open each  *.csv file

    For j = 1 To FC

        '1. Path

        lngStart = 1

        Do

            backslash = InStr(lngStart, f(j), "\")

            If backslash = 0 Then

                fcsv(j) = Right(f(j), Len(f(j)) - lngStart + 1)

            Else

                lngStart = backslash + 1

            End If

        Loop While backslash > 0

        '2. File name

        lngStart = 1

        dot = InStr(lngStart, fcsv(j), ".")

        ind(j) = Left(fcsv(j), dot - 1)

        

        Workbooks.Open f(j)

       

    Next j



Windows(ind(1)).Activate

URR = Application.CountA(ActiveSheet.Range("A:A"))

URC = Application.CountA(ActiveSheet.Range("1:1"))

p = 2

q = 1

For j = 1 To URC - 1

 

  

  'copy data from files

  Windows(ind(1)).Activate

  Yname = Cells(1, j + 1)

  For i = 1 To URR - 1

  data(1, i) = Cells(i + 1, j + 1)

  Next i



  For M = 2 To FC

  Windows(ind(M)).Activate

  URC2 = Application.CountA(ActiveSheet.Range("1:1"))

  URR2 = Application.CountA(ActiveSheet.Range("A:A"))

   For n = 1 To URC2

    If Cells(1, n) = Yname Then

      For i = 1 To URR2 - 1

      data(M, i) = Cells(i + 1, j + 1)

      Next i

      Exit For

    End If

   Next n

  Next M

  

  'paste data to "RTD CHARTS"

  Windows("RTD CHARTS").Activate

  For i = 1 To FC

    Cells(101, 1 + i - FC + FC * j) = Yname

    Cells(100, 1 + i - FC + FC * j) = ind(i)

    For M = 1 To URR2 - 1

    Cells(M + 101, 1 + i - FC + FC * j) = data(i, M)

    Next M

  Next i

  

'make Charts

    If j > 1 Then

    Cells(1, 1).Select

    

    If p = 7 Then

    p = 2

    q = q + 1

    End If

    ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers, Cells(2 + (q - 1) * 16, 2 + 8 * (p - 2)).Left, Cells(2 + (q - 1) * 16, 2 + 8 * (p - 2)).Top).Select

    p = p + 1

    

    ActiveChart.ChartTitle.Text = Cells(101, (j - 1) * FC + 3)

    For i = 1 To FC

    ActiveChart.SeriesCollection.NewSeries

    ActiveChart.FullSeriesCollection(i).Name = Cells(100, 1 + i)

    URR = Application.CountA(ActiveSheet.Range(Cells(1, i + 1), Cells(5000, i + 1)))

    ActiveChart.FullSeriesCollection(i).XValues = Range(Cells(102, i + 1), Cells(URR, i + 1))

    URR = Application.CountA(ActiveSheet.Range(Cells(1, 1 + i - FC + FC * j), Cells(5000, 1 + i - FC + FC * j)))

    ActiveChart.FullSeriesCollection(i).Values = Range(Cells(102, 1 + i - FC + FC * j), Cells(URR, 1 + i - FC + FC * j))

    Next i

    ActiveChart.SetElement (msoElementLegendBottom)

    End If

    

 Erase data()

Next j









'close the files one by one

For j = 1 To FC

     Windows(fcsv(j)).Activate

     ActiveWorkbook.Close SaveChanges:=False

Next j



    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

MsgBox "Time-consuming is " & Format(Now() - tm, "hh:mm:ss")

End Sub