运行过程需要很长的时间
这里我的代码：运行过程需要很长的时间
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分钟，并找不到解决方案来缩短时间。
在此先感谢
由于我的建议的一个例子，我改编的第一行，你可以试试这个，我希望它会提高你的代码的性能。
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
我在这条线上应用但调试为“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
不幸的是你的代码创建了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的
“等等......
末次
可能是一个用于http://codereview.stackexchange.com/ –
我想，所有的列需要扩大问题直到同一排右边？然后你可以先获得你的数据的最后一行，这样就避免了.End（xlDown）很多次 –
是的，扩展到同一行的权利 – ZRS