Question

我使用以下代码来组合文本行。第一行没有空格，然后下面的随机数行在第二个字符中有一个空格。我将这些行移动到没有空格的行，并在前一个单元格的右侧，然后检查下一个单元格。代码功能完美，但速度很慢。我正在运行Gen 1 i3 3.2Ghz，8GB内存和Excel 2010 64位，所以它不是系统。但是，这将运行的生产系统是Core2 Duo 2.5-3Ghz，可用3.2GB RAM，因此速度较慢，并且运行Excel 2007 32位。 UPD：在此过程中屏幕更新和计算已关闭。

任何人都可以帮助优化它吗？示例行如下。如果它看起来很快，只需复制数据大约40,000次。我的文件每个包含大约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

Answer 1

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 A-D
    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

编辑：已更新，以便将内容保留在A-C列

中

Answer 2

最快的方法是将范围加载到数组并进行更改，然后将它们吐回到工作表之后，但坚持使用逻辑，你可以用更像这样的东西替换你的while循环：

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

这将简单地移动值而无需选择单元格，剪切和粘贴等。

希望这有助于您朝着正确的方向前进。

需要优化我的代码，根据字符串移动单元格

2 个答案: