需要优化我的代码，基于string移动单元格
我正在使用下面的代码来组合文本行。 第一行没有空格，那么在第二个字符中有一个随机数字的下面有空格。 我将这些行移动到没有空格的行，并在前一个单元格的右侧，然后检查下一个单元格。 代码function完美，但速度很慢。 而我正在运行一个Gen 1 i3 3.2Ghz与8GB的RAM和Excel 2010 64位，所以它不是系统。 然而，这个将运行的生产系统是一个Core2 Duo2.5-3Ghz与3.2GB RAM可用，如此慢，并运行Excel 2007 32位。 UPD：在此过程中屏幕更新和计算已closures。
任何人都可以帮助优化它吗？ 示例行如下。 如果你看起来很快，只需要复制约40000次的数据。 我的文件每个包含大约90k行。 完成后，他们结合到20K左右。 数据的处理是在这个过程之前和之后完成的，但这是杀手。 一如既往，在此先感谢！
Range("d1").Select Do Until ActiveCell.Value = "" i = ActiveCell.Value If Mid(i, 2, 1) = " " Then ActiveCell.Cut ActiveCell.Offset(-1, 0).End(xlToRight).End(xlToRight).End(xlToLeft).Offset(0, 1).Select ActiveSheet.Paste ActiveCell.Offset(1, 0).End(xlToLeft).Offset(0, 1).Select ActiveCell.EntireRow.Delete CutCopyMode = False Else: ActiveCell.Offset(1, 0).Select End If Loop 示例单元格：
10/1/2013 1:27:02 AM [501014 ]CODELINE_INDICATION_MSG 192.168.013.212 606.1.01 (9781) RX 38 bytes 10/1/2013 1:27:02 AM [501014 ] 97 81 29 00 38 00 EA 23 4A A3 55 A1 73 4A 5A 1A 10/1/2013 1:27:02 AM [501014 ] 14 A2 A2 00 2E 02 02 12 8B 03 00 08 08 01 00 01 10/1/2013 1:27:02 AM [501014 ] 10 51 00 01 00 11 10/1/2013 1:27:03 AM [501014 ]CODELINE_INDICATION_MSG 192.168.013.212 606.1.01 (9781) RX 38 bytes 10/1/2013 1:27:03 AM [501014 ] 97 81 29 00 3A 00 EA 23 4A A3 55 A1 73 4A 5A 1A 10/1/2013 1:27:03 AM [501014 ] 14 A2 A2 00 2E 02 02 12 8B 03 00 08 08 01 00 01 10/1/2013 1:27:03 AM [501014 ] 10 51 00 01 00 11 10/1/2013 1:28:59 AM [501014 ]CODELINE_RECALL_MSG 192.168.013.254:0000 RX 26 bytes 10/1/2013 1:28:59 AM [501014 ] 00 00 26 00 B2 02 AE 73 4A 5A 1A 14 A2 A2 23 4A 10/1/2013 1:28:59 AM [501014 ] A1 31 A2 00 2C 02 02 12 48 03 10/1/2013 1:28:59 AM [501014 ]INT_L3_ATCS 010.1.13 (28d) TX 29 bytes 10/1/2013 1:28:59 AM [501014 ] 02 8D 25 00 98 00 AE 73 4A 5A 1A 14 A2 A2 23 4A 10/1/2013 1:28:59 AM [501014 ] A3 55 A1 00 3A 02 02 12 48 03 00 00 08 10/1/2013 1:28:59 AM [501014 ]INT_L3_ATCS 010.1.13 (28d) TX 29 bytes 10/1/2013 1:28:59 AM [501014 ] 02 8D 25 00 98 00 AE 73 4A 5A 1A 14 A2 A2 23 4A 10/1/2013 1:28:59 AM [501014 ] A3 55 A1 00 3A 02 02 12 48 03 00 00 08 10/1/2013 1:29:00 AM [501014 ]CODELINE_INDICATION_MSG 010.150.100.050 010.1.13 (28d) RX 38 bytes 10/1/2013 1:29:00 AM [501014 ] 02 8D 68 00 1E 00 EA 23 4A A3 55 A1 73 4A 5A 1A 10/1/2013 1:29:00 AM [501014 ] 14 A2 A2 00 30 02 02 12 8B 03 00 08 08 01 00 01 10/1/2013 1:29:00 AM [501014 ] 10 51 00 01 00 3D
160k行2秒：
Sub Tester() Dim tmp Dim arr, r As Long, numR As Long, maxW As Long, w As Long Dim arrOut(), rwOut As Long, colOut As Long 'read info from columns AD With ActiveSheet arr = .Range(.Range("A1"), .Cells(.Rows.Count, 4).End(xlUp)) End With numR = UBound(arr, 1) 'Find how "wide" the output array needs to be ' could skip this if you know the max possible width... maxW = 0 w = 0 For r = 1 To numR If Mid(arr(r, 4), 2, 1) = " " Then w = w + 1 Else If w > maxW Then maxW = w w = 0 End If Next r 'resize output array ReDim arrOut(1 To numR, 1 To maxW + 4) rwOut = 0 colOut = 5 'populate the output array For r = 1 To numR tmp = arr(r, 4) If Mid(tmp, 2, 1) = " " Then If rwOut = 0 Then rwOut = 1 'in case first "non-space" line is missing arrOut(rwOut, colOut) = tmp colOut = colOut + 1 Else rwOut = rwOut + 1 arrOut(rwOut, 1) = arr(r, 1) arrOut(rwOut, 2) = arr(r, 2) arrOut(rwOut, 3) = arr(r, 3) arrOut(rwOut, 4) = tmp colOut = 5 End If Next r 'put output array onto worksheet ActiveSheet.Range("A1").Resize(numR, maxW + 4).Value = arrOut End Sub
编辑 ：更新为帐户保持在列AC的内容
最快的方法是将范围加载到数组中并进行更改，然后将它们吐出到工作表中，但是坚持使用逻辑，可以用更类似的方式replacewhile循环：
Do Until ActiveCell.Value = "" i = ActiveCell.Value If Mid(i, 2, 1) = " " Then ActiveCell.Offset(-1, ActiveSheet.Columns.Count - 7).End(xlToLeft).Offset(0, 1).Value = ActiveCell.Value ActiveCell.EntireRow.Delete Else: ActiveCell.Offset(1, 0).Select End If Loop
这将简单地移动数值而不必select单元格，剪切和粘贴等。
希望这有助于你朝着正确的方向前进。