优化excel VBA代码-合并常驻地址

Question

我已经在excel中完成了以下两个VBA代码。主要目的是将多个地址行合并成一行。问题是它要花很长时间才能运行。有什么我可以优化的吗？

数据是这样的，每个客户地址都有一个case#。客户地址可以分成多个行。例如：“地址第1行-56座”、“地址第2行- Parry Avenue”、“地址第3行-邮政编码”。每个新地址之间都有一个空格。

我的目的是将地址合并成一行，并删除箱号之间的空行，例如“Parry Avenue邮政编码56号块”。大约有26K个病例号。

Sub test()


Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String

Application.EnableEvents = False
Application.ScreenUpdating = False

Set wks = Sheets("data")
wks.Activate

lEnd = ActiveSheet.UsedRange.Rows.Count

For l = 3 To lEnd
    If Not IsEmpty(Cells(l, 1)) Then
            Do Until IsEmpty(Cells(l + 1, 4))
                temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
                Cells(l, 4).Value = temp
                Cells(l + 1, 4).EntireRow.Delete
            Loop

    Else: Cells(l, 1).EntireRow.Delete
            Do Until IsEmpty(Cells(l + 1, 4))
                temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
                Cells(l, 4).Value = temp
                Cells(l + 1, 4).EntireRow.Delete
            Loop
    End If


Next l

End Sub

我试过的第二个密码

Sub transformdata()
'
Dim temp As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range("A3").Select

Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
    Do Until IsEmpty(ActiveCell.Offset(1, 3))
            temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
            ActiveCell.Offset(, 3).Value = temp
            ActiveCell.Offset(1, 3).EntireRow.Delete
     Loop

    ActiveCell.Offset(1, 0).EntireRow.Delete
    ActiveCell.Offset(1, 0).Select

    Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Answer 1

1. 更改行lEnd = ActiveSheet.UsedRange.Rows.Count。找最后一行的方法不正确。你可能想看This
2. 若要删除Cells(l, 1)为空的行，请使用自动筛选器。请参阅This
3. 不要删除直线循环中的行。使用反向循环。或者，您可以做的是识别要在循环中删除的单元格，然后在循环之后一次删除它们。你可能想看This

下面是一个基本的例子。

假设你的工作表是这样的

​

​

如果您运行此代码

Sub test()
    Dim wks As Worksheet
    Dim lRow As Long, i As Long
    Dim temp As String

    Application.ScreenUpdating = False

    Set wks = Sheets("data")

    With wks
        '~~> Find Last Row
        lRow = .Range("C" & .Rows.Count).End(xlUp).Row

        For i = lRow To 2 Step -1
            If Len(Trim(.Range("C" & i).Value)) <> 0 Then
                If temp = "" Then
                    temp = .Range("C" & i).Value
                Else
                    temp = .Range("C" & i).Value & "," & temp
                End If
            Else
                .Range("D" & i + 1).Value = temp
                temp = ""
            End If
        Next i
    End With
End Sub

你会得到这个输出

​

​

现在，只需运行自动筛选器，删除Col D为空的行:)，我已经为您提供了上面的链接。

Answer 2

下面的代码将将所有数据复制到数组中，合并数据并将其添加到新的工作表中。您需要使COLUMNCOUNT =包含数据的列数。

​

​

Sub TransformData2()
    Const COLUMNCOUNT = 4
    Dim SourceData, NewData
    Dim count As Long, x1 As Long, x2 As Long, y As Long

    SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))

    For x1 = 1 To UBound(SourceData, 1)

        count = count + 1
        If count = 1 Then
            ReDim NewData(1 To 4, 1 To count)
        Else
            ReDim Preserve NewData(1 To 4, 1 To count)
        End If

        For y = 1 To UBound(SourceData, 2)
            NewData(y, count) = SourceData(x1, y)
        Next

        x2 = x1 + 1

        Do
            NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
            x2 = x2 + 1
            If x2 > UBound(SourceData, 1) Then Exit Do
        Loop Until IsEmpty(SourceData(x2, 4))
        x1 = x2
    Next

    ThisWorkbook.Worksheets.Add
    Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub