Question

我在excel中完成了以下2个VBA代码。主要目的是将多个地址行组合成一行。问题是它需要永远运行。无论如何我可以优化它吗？

数据就是这样，每个客户地址都有一个案例＃。客户地址可以拆分为多行。示例：＆＃34;地址第1行 - 第56行＆＃34;，＆＃34;地址第2行 - Parry Avenue＆＃34;，＆＃34;地址第3行 - 邮政编码＆＃34;。每个新地址之间都有一个空格。

我的目的是将地址合并为一行，并删除案例编号之间的空行，例如＆＃34; Block 56 Parry Avenue邮政编码＆＃34;。大约有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

更改第lEnd = ActiveSheet.UsedRange.Rows.Count行。查找最后一行的方法不正确。您可能希望查看This
要删除Cells(l, 1)为空的行，请使用自动过滤器。请参阅This
不要直接删除行。使用反向循环。或者你可以做的是在循环中识别要删除的单元格，然后在循环后一次删除它们。您可能希望查看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

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

2 个答案: