Optimise excel VBA code - combine resident address

Question

I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?

The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.

My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.

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

and the 2nd code I tried

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

Can you share us a picture(s) of your worksheet and your sample data? It'd help to understand your request — Anastasiya-Romanova 秀, Aug 11 '16 at 06:11

score 1 · Accepted Answer · edited May 23 '17 at 12:32

1

Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This

Here is a basic example.

Let's say your worksheet looks like this

If you run this code

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

You will get this output

Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.

edited May 23 '17 at 12:32

Community

1
1

answered Aug 11 '16 at 06:13

Siddharth Rout

147,039
17
206
250

You need to turn`Application.ScreenUpdating` back on. – Aug 11 '16 at 07:24
No it goes back on after sub ends – Steven Martin Aug 11 '16 at 08:42
@ThomasInzina: Yup you are right. The above is a part of the main code. At the end the screenupdating needs to be turned back on :) – Siddharth Rout Aug 11 '16 at 09:26
@SiddharthRout I tried to use the autofilter to delete the rows. It takes very long to complete. The code I'm using as below. Can you please tell me whats wrong? `With .Range("A1:A" & lRow) .AutoFilter Field:=1, Criteria1:="=" .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete End With ` – MX Lee Aug 15 '16 at 02:18
I have resolved it by sorting the blanks to the bottom before deleting. Thanks for the help – MX Lee Aug 15 '16 at 04:22

score 0 · Answer 2 · answered Aug 11 '16 at 07:11

The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.

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

Optimise excel VBA code - combine resident address

2 Answers2