運行過程需要很長的時間

這裏我的代碼：運行過程需要很長的時間

Private Sub CopyRanges() 

Sheets("Test2").Activate 

Application.ScreenUpdating = False 

Application.DisplayAlerts = False 

Range(ActiveSheet.Columns("A"), ActiveSheet.Columns("A").End(xlDown)).Value = Range(Sheets("Test1").Columns(2), Sheets("Test1").Columns(2).End(xlDown)).Value 

Range(ActiveSheet.Columns("B"), ActiveSheet.Columns("B").End(xlDown)).Value = Range(Sheets("Test1").Columns(23), Sheets("Test1").Columns(23).End(xlDown)).Value 

Range(ActiveSheet.Columns("C:D"), ActiveSheet.Columns("C:D").End(xlDown)).Value = Range(Sheets("Test1").Columns(3), Sheets("Test1").Columns(3).End(xlDown)).Value 

Range(ActiveSheet.Columns("E:F"), ActiveSheet.Columns("E:F").End(xlDown)).Value = Range(Sheets("Test1").Columns(4), Sheets("Test1").Columns(4).End(xlDown)).Value 

Range(ActiveSheet.Columns("G:H"), ActiveSheet.Columns("G:H").End(xlDown)).Value = Range(Sheets("Test1").Columns(5), Sheets("Test1").Columns(5).End(xlDown)).Value 

Range(ActiveSheet.Columns("I:J"), ActiveSheet.Columns("I:J").End(xlDown)).Value = Range(Sheets("Test1").Columns(6), Sheets("Test1").Columns(6).End(xlDown)).Value 

Range(ActiveSheet.Columns("K:L"), ActiveSheet.Columns("K:L").End(xlDown)).Value = Range(Sheets("Test1").Columns(7), Sheets("Test1").Columns(7).End(xlDown)).Value 

Range(ActiveSheet.Columns("M:N"), ActiveSheet.Columns("M:N").End(xlDown)).Value = Range(Sheets("Test1").Columns(8), Sheets("Test1").Columns(8).End(xlDown)).Value 

Range(ActiveSheet.Columns("O:P"), ActiveSheet.Columns("O:P").End(xlDown)).Value = Range(Sheets("Test1").Columns(9), Sheets("Test1").Columns(9).End(xlDown)).Value 

Range(ActiveSheet.Columns("Q:R"), ActiveSheet.Columns("Q:R").End(xlDown)).Value = Range(Sheets("Test1").Columns(10), Sheets("Test1").Columns(10).End(xlDown)).Value 

Range(ActiveSheet.Columns("S:T"), ActiveSheet.Columns("S:T").End(xlDown)).Value = Range(Sheets("Test1").Columns(11), Sheets("Test1").Columns(11).End(xlDown)).Value 

Range(ActiveSheet.Columns("U:V"), ActiveSheet.Columns("U:V").End(xlDown)).Value = Range(Sheets("Test1").Columns(12), Sheets("Test1").Columns(12).End(xlDown)).Value 

Range(ActiveSheet.Columns("W:X"), ActiveSheet.Columns("W:X").End(xlDown)).Value = Range(Sheets("Test1").Columns(13), Sheets("Test1").Columns(13).End(xlDown)).Value 

Range(ActiveSheet.Columns("Y:Z"), ActiveSheet.Columns("Y:Z").End(xlDown)).Value = Range(Sheets("Test1").Columns(14), Sheets("Test1").Columns(14).End(xlDown)).Value 

Dim rCell As Range 

Dim rRng As Range 

    For Each rCell In Range("C1:D800") 

     If rCell.Value = "Maximum accomodation in room is" Then 

      If rRng Is Nothing Then 

       Set rRng = rCell 

      Else 

       Set rRng = Application.Union(rRng, rCell) 

      End If 

     End If 

    Next 

    rRng.Offset(, 0).Select 
    Selection.EntireRow.Unmerge 
    Selection.HorizontalAlignment = xlGeneral 

    Columns("A").Replace What:=",99", Replacement:="", LookAt:= _ 
     xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ 
     ReplaceFormat:=False 

    Columns("A").Replace What:=",00", Replacement:="", LookAt:= _ 
     xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ 
     ReplaceFormat:=False 

    Range("B5").Select 

    Application.DisplayAlerts = True 

    Application.ScreenUpdating = True 

    Application.Run "ResizeAll" 

End Sub

VBA的效果很好，除了時機。程序需要7-10分鐘，並找不到解決方案來縮短時間。

在此先感謝

來源

2017-03-03 ZRS

可能是一個用於http://codereview.stackexchange.com/ –

我想，所有的列需要擴大問題直到同一排右邊？然後你可以先獲得你的數據的最後一行，這樣就避免了.End（xlDown）很多次 –

是的，擴展到同一行的權利 – ZRS

由於我的建議的一個例子，我改編的第一行，你可以試試這個，我希望它會提高你的代碼的性能。

Test2LastRow =Sheets("Test2").Cells(Rows.Count, 1).End(xlUp).Row 
Test1LastRow =Sheets("Test1").Cells(Rows.Count, 1).End(xlUp).Row 

Sheets("Test2").Range("A1:A" & Test2LastRow & "").Value = Sheets("Test1").Range("B1:B" & Test1LastRow & "").Value

來源

2017-03-03 13:30:57

我在這條線上應用但調試爲「Object Variable or block variable not set」 rRng.Offset（，0）.Select – ZRS

有點難以遵循你的代碼正在做什麼 - 重新安排列和重複其中的一些？似乎Test2列C & D等於Test1列3？

我發現一些代碼，看起來像它可以加快速度（https://www.mrexcel.com/forum/excel-questions/606890-reorder-columns-using-macro.html）

用這種方法你列進行排序按所需的順序，並使用FIND，而不是通過每個單元循環：

Private Sub CopyRanges() 

    Dim NewColOrder As Variant 
    Dim x As Long 
    Dim rLastCell As Range 
    Dim rFound As Range 
    Dim FirstFound As String 
    Dim rRng As Range 

    'This is the order you want the columns in. 
    'So the 26th column should be in position 2. 
    'Column 3 is repeated twice: Columns("C:D") = Columns(3) in your code. 
    NewColOrder = Array(1, 3, 3, 5, 5, 7, 7, 9, 9, 11, 11, 13, 13, 15, 15, 17, 17, 19, 19, 21, 21, 23, 23, 25, 25, 2) 

    With ThisWorkbook 
     With .Worksheets("Test1") 

      'Create copies of repeated columns. 
      For x = LBound(NewColOrder) + 1 To UBound(NewColOrder) 
       If NewColOrder(x) = NewColOrder(x - 1) Then 
        .Columns(NewColOrder(x)).EntireColumn.Insert Shift:=xlToRight 
        .Columns(NewColOrder(x) - 1).Copy Destination:=.Columns(NewColOrder(x)) 
       End If 
      Next x 

      'Add a new row and put desired column order in row. 
      .Range("A1").EntireRow.Insert 
      .Range("A1").Resize(1, UBound(NewColOrder) + 1) = NewColOrder 

      'Find the last cell containing data. 
      Set rLastCell = .Cells.Find("*", , , , xlByRows, xlPrevious) 

      'Sort the data into the correct column order. 
      .Range(.Cells(1, 1), rLastCell).Sort .Cells(1), 1, Orientation:=xlLeftToRight 

      'Copy the data over to Test1. 
      .Range(.Cells(2, 1), rLastCell).Copy Destination:=ThisWorkbook.Worksheets("Test2").Range("A1") 
     End With 

     'Now to find "Maximum accomodation in room is" 
     With .Worksheets("Test2") 

      'Find the last cell containing data. 
      Set rLastCell = .Cells.Find("*", , , , xlByRows, xlPrevious) 

      With .Range(.Cells(3, 1), rLastCell) 
       Set rFound = .Find("Maximum accomodation in room is", LookIn:=xlValues) 
       If Not rFound Is Nothing Then 
        FirstFound = rFound.Address 
        Do 
         If rRng Is Nothing Then 
          Set rRng = rFound 
         Else 
          Set rRng = Union(rRng, rFound) 
         End If 
         Set rFound = .FindNext(rFound) 
        Loop While rFound.Address <> FirstFound 
       End If 

       'Not quite sure what you're trying to do here. 
       If Not rRng Is Nothing Then 
        rRng.EntireRow.UnMerge 
        rRng.HorizontalAlignment = xlGeneral 
       End If 
      End With 

      .Columns(1).Replace What:=",99", Replacement:="", LookAt:=xlPart 
      .Columns(1).Replace What:=",00", Replacement:="", LookAt:=xlPart 

     End With 
    End With 

End Sub

來源

2017-03-03 14:38:27

不幸的是你的代碼創建了dublicates。 Test1包含我的行數據，但沒有訂單，因此vba會將test1數據重組爲test2。我把test1，test2（我的代碼）和test2（你的代碼）的鏈接放在下面以闡明： https://www.imageupload.co.uk/image/BjE3 https://www.imageupload.co。 uk/image/BjEL https://www.imageupload.co.uk/image/BjEW – ZRS

我以爲這就是你的代碼所做的。 'Range（ActiveSheet.Columns（「C：D」），ActiveSheet.Columns（「C：D」）。End（xlDown））。Value = Range（Sheets（「Test1」）。Columns（3），Sheets（「 Test1「）。Columns（3）.End（xlDown））。Value'這是否將第3列放在C：D列中？ –

我的代碼將test1 column3值複製到test2工作表中的C：D（合併）列中。我的第三方機構計劃只能通過這種方式讀取數據。 Test1是我的合同設計，但我必須在test2中重新排列它以供代理軟件閱讀 – ZRS

我改變了我的代碼第1部分和現在的工作要比以前快多了：

私人小組CopyRanges（）

昏暗wsTest2作爲工作表，wsTest1作爲工作表

昏暗LR只要

集wsTest2 = ActiveWorkbook.Sheets（「Test2的」）

集wsTest1 = ActiveWorkbook.Sheets（「測試1」）

隨着應用

.ScreenUpdating = False 

.DisplayAlerts = False

末隨着

wsTest2.Activate

LR = wsTest1.UsedRange.Rows（wsTest1.UsedRange.Rows.Count）.Row

wsTest2.Range（「A1：A」 & LR）。價值= wsTest1.Range（」 B1：B」 & LR）。價值

wsTest2.Range（「B1：B」 & LR）。價值= wsTest1.Range（「W1：W」 & LR）。價值

wsTest2.Range（「C1：D」& lr）.Value = wsTest1.Range（「C1：C」& lr）。值

wsTest2.Range（「E1：F」 & LR）。價值= wsTest1.Range（「D1：d」 & LR）。價值

wsTest2.Range（「G1：H」 & LR）。值= wsTest1.Range（「E1：E」 & LR）。價值

wsTest2.Range（「I1：J」 & LR）。價值= wsTest1.Range（「F1：F」 & LR）。值

wsTest2.Range（「K1：L」 & LR）。價值= wsTest1.Range（「G1：G」 & LR）。價值

wsTest2.Range（「M1：N」 & LR） .value的= wsTest1.Range（「H1：H」 & LR）。價值

wsTest2.Range（「01：P」 & LR）。價值= wsTest1.Range（「I1：I」 & LR）。價值

wsTest2.Range（「Q1：R」& lr）.Value = wsTest1.Range（「J1：J」& LR）。價值

wsTest2.Range（「S1：T」 & LR）。價值= wsTest1.Range（「K1：K」 & LR）。價值

wsTest2.Range（「U1：V 「& LR）。價值= wsTest1.Range（」 L1：L」 & LR）。價值

wsTest2.Range（「W1：X」 & LR）。價值= wsTest1.Range（「M1：M」 & lr）.Value

wsTest2.Range（「Y1：Z」& lr）.Value = wsTest1.Range（「N1：N」& LR）.value的

「等等......

末次

來源

2017-03-06 07:50:41 ZRS

運行過程需要很長的時間

回答

相關問題