跪求各位大侠，我的代码太啰嗦，运行太慢，请帮忙优化

SYSMEX530

以下是代码 ，
附有文件。

Sub 写入多工作簿()
    Dim mypath$, myfile$, AK As Workbook, aRow%, tRow%, i As Integer, sht As Worksheet, rt, J As Long
    Application.ScreenUpdating = False
    mypath = ThisWorkbook.Path & "\"
       myfile = Dir(mypath & "*.xls")
       Do While myfile <> ""
          If myfile <> ThisWorkbook.Name Then
             Set AK = Workbooks.Open(mypath & myfile)
              Application.DisplayAlerts = False
                For Each sht In Worksheets
                If sht.Name Like "*(*左右*)" Then sht.Activate
                Next
                Application.DisplayAlerts = True
                  rt = ActiveSheet.Range("R65536").End(xlUp).Row  '以下21行是删除赔率的最大最小值,减少大数据的负面干扰.
                  For J = rt To 7 Step -1
                  If Range("i" & J) >= 1.06 Then
                  Rows(J).Delete
                  End If
                  If Range("i" & J) <= 0.85 Then
                  Rows(J).Delete
                  End If
                  If Range("j" & J) > 1.12 Then
                  Rows(J).Delete
                  End If
                  If Range("j" & J) < 0.69 Then
                  Rows(J).Delete
                  End If
                  If Range("k" & J) >= 1.06 Then
                  Rows(J).Delete
                  End If
                  If Range("k" & J) <= 0.85 Then
                  Rows(J).Delete
                  End If
                  If Range("h" & J) < [H5] Then
                  Rows(J).Delete
                  End If
                  If [H5] < 0.92 And Range("h" & J) >= 0.96 Then
                  Rows(J).Delete
                  Else
                  If [H5] > 0.92 And Range("h" & J) >= 0.97 Then
                  Rows(J).Delete
                  End If
                  End If
                  Next J
             Select Case ActiveSheet.[A9].CurrentRegion.Rows.Count
             Case Is > 50
             lr = Range("a65536").End(xlUp).Row + 1
             mr = Range("U65536").End(xlUp).Row
        Workbooks("布莱克本VS维冈竞技(英冠)欧洲数据2014.9.2").Sheets(2).Range("I7:Q" & mr).Copy
             ActiveSheet.Range("I7:Q" & mr).Select
             ActiveSheet.Paste
        'Workbooks("布莱克本VS维冈竞技(英冠)欧洲数据2014.9.2").Sheets(2).Range("L7:N350").Copy
            ' ActiveSheet.Range("L7:N350").Select
            ' ActiveSheet.Paste
        Workbooks("布莱克本VS维冈竞技(英冠)欧洲数据2014.9.2").Sheets(2).Range("V7:AD" & mr).Copy
             ActiveSheet.Range("V7:AD" & mr).Select
             ActiveSheet.Paste
        Workbooks("布莱克本VS维冈竞技(英冠)欧洲数据2014.9.2").Sheets(2).Range("A391:AL473").Copy
             ActiveSheet.Range("A" & lr).Select
             ActiveSheet.Paste
        ActiveSheet.Range("b65536").End(xlUp).Offset(-61, 0).Resize(1, 3).Copy
             ActiveSheet.[e5:g5].Select
             ActiveSheet.Paste
             Selection.PasteSpecial Paste:=xlPasteValues
        ActiveSheet.Range("b65536").End(xlUp).Offset(-61, 23).Resize(1, 3).Copy
             ActiveSheet.[e6:g6].Select
             ActiveSheet.Paste
             Selection.PasteSpecial Paste:=xlPasteValues
        ActiveSheet.Range("b65536").End(xlUp).Offset(-60, 0).Resize(1, 3).Copy
             ActiveSheet.[I5:K5].Select
             ActiveSheet.Paste
             Selection.PasteSpecial Paste:=xlPasteValues
             ActiveSheet.Cells.Columns("A:A").ColumnWidth = 13
             ActiveSheet.Cells.Columns("B:AD").ColumnWidth = 6.18
             Workbooks(myfile).Close True
             ActiveWorkbook.Save
             Case Is < 50
        Workbooks("布莱克本VS维冈竞技(英冠)欧洲数据2014.9.2").Sheets(3).Range("A20:BA230").Copy
             ActiveSheet.Range("A20:BA230").Select
             ActiveSheet.Paste
             Workbooks(myfile).Close True
             ActiveWorkbook.Save
             End Select
           End If
          myfile = Dir
       Loop
   Application.ScreenUpdating = True
   MsgBox "数据更新完毕！", 164, "提示"
End Sub

蓝桥玄霜

用于赌球的？

liulang0808

建议使用数组吧，另外删除行，使用一次性删除

SYSMEX530

liulang0808 发表于 2015-11-5 13:21
建议使用数组吧，另外删除行，使用一次性删除

Excel 跪求各位大侠，我的代码太啰嗦，运行太慢，请帮忙优化-ExcelVBA程序开发-ExcelHome技术论坛 -
http://club.excelhome.net/thread-1239709-1-1.html

hlly888

表格有点乱，请详细说明要求，最好模拟结果。

SYSMEX530

hlly888 发表于 2015-11-5 21:35
表格有点乱，请详细说明要求，最好模拟结果。

我自己写这代码运行太慢，请帮忙优化。http://club.excelhome.net/thread-1239709-1-1.html

SYSMEX530

hlly888 发表于 2015-11-5 21:35
表格有点乱，请详细说明要求，最好模拟结果。

关键就是在多处复制时的啰嗦，最好用数组，但是动态数组我不会。

hlly888

SYSMEX530 发表于 2015-11-5 21:39
我自己写这代码运行太慢，请帮忙优化。http://club.excelhome.net/thread-1239709-1-1.html

分析代码很头痛，请详细说明要求

SYSMEX530

hlly888 发表于 2015-11-5 21:45
分析代码很头痛，请详细说明要求

我用到 COPY 高达7处，我想把它优化后，提高代码运行速度。

phsu

(1)以下這個循環是沒有意義的。若有兩個以上的工作表符合條件，只有最後一個工作表會被激活。
For Each sht In Worksheets
        If sht.Name Like "*(*左右*)" Then sht.Activate
Next
(2)下列這些IF重複，應該改成用一個IF處理。例如If Range("i" & J) >= 1.06 Or Range("i" & J) <= 0.85 Or ....
If Range("i" & J) >= 1.06 Then
        Rows(J).Delete
End If
If Range("i" & J) <= 0.85 Then
        Rows(J).Delete
End If