CODEWITHSUNDEEP
excelvba
evyxmsj
evyxmsj

Reputation: 3

Copying from from one range to another ignoring blanks (Excel)

I'm trying to copy a range from one sheet to another, but ignoring blank rows, and making sure there aren't blank rows in the destination.

After looking on this site, I've successfully used the code below.

However, I want to expand this to a large data range and it seems to take an absolute age. Any ideas on a more efficient code? Slight newbie here!

Thanks!

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim Source As Worksheet
Dim Destination As Worksheet
Dim i As Integer
Dim j As Integer

Set Source = Sheet1
Set Destination = Sheet4

j = 2
For i = 9 To 10000
    If Source.Cells(i, 2).Value <> "" Then
        Destination.Cells(j, 1).Value = Source.Cells(i, 1).Value
        Destination.Cells(j, 2).Value = Source.Cells(i, 2).Value
        Destination.Cells(j, 3).Value = Source.Cells(i, 3).Value
        Destination.Cells(j, 4).Value = Source.Cells(i, 4).Value
        Destination.Cells(j, 5).Value = Source.Cells(i, 5).Value
        Destination.Cells(j, 6).Value = Source.Cells(i, 6).Value
        Destination.Cells(j, 7).Value = Source.Cells(i, 7).Value
        Destination.Cells(j, 8).Value = Source.Cells(i, 8).Value
        Destination.Cells(j, 9).Value = Source.Cells(i, 9).Value
        j = j + 1
    End If
Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic

End Sub

[Edited to add a bit of clarity]

Upvotes: 0

Views: 57

Answers (2)

user4039065
user4039065

Reputation:

Looping through worksheet rows is almost the slowest way to process data blocks. The only thing slower is looping through both rows and columns.

I'm not sure how many records you have but this processed 1500 rows of dummy data in ~0.14 seconds.

Option Explicit

Sub Macro4()

    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim i As Long, j As Long, k As Long, arr As Variant

    On Error GoTo safe_exit
    appTGGL bTGGL:=False

    Set wsSource = Sheet1
    Set wsDestination = Sheet4

    'collect values from Sheet1 into array
    With wsSource
        arr = .Range(.Cells(9, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 7)).Value
    End With

    'find first blank in column B
    For j = LBound(arr, 1) To UBound(arr, 1)
        If arr(j, 2) = vbNullString Then Exit For
    Next j

    'collect A:I where B not blank
    For i = j To UBound(arr, 1)
        If arr(i, 2) <> vbNullString Then
            For k = 1 To 9: arr(j, k) = arr(i, k): Next k
            j = j + 1
        End If
    Next i

    'clear remaining rows
    For i = j To UBound(arr, 1)
        For k = 1 To 9: arr(i, k) = vbNullString: Next k
    Next i

    'put values sans blanks into Sheet4
    With wsDestination
        .Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

safe_exit:
    appTGGL

End Sub

Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .EnableEvents = bTGGL
        .ScreenUpdating = bTGGL
        .DisplayAlerts = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    End With
    Debug.Print IIf(bTGGL, "end: ", "start: ") & Timer
End Sub

Upvotes: 1

newacc2240
newacc2240

Reputation: 1425

Replace your for loop with codes below.

Method 1: union all the range you would like to copy, and paste them at once.

    Dim copyRange As Range

    For i = 9 To 10000
        If Source.Cells(i, 2).Value <> "" Then
            If copyRange Is Nothing Then
                Set copyRange = Source.Range(Source.Cells(i, 1), Source.Cells(i, 9))
            Else
                Set copyRange = Union(copyRange, Source.Range(Source.Cells(i, 1), Source.Cells(i, 9)))
            End If
        End If
    Next i

    copyRange.Copy Destination.Cells(2, 1)

Method 2(recommended): Use an autofilter for filtering the data.

    Dim sourceRng As Range
    Set sourceRng = Source.Range(Source.Cells(9, 1), Source.Cells(10000, 9))

    sourceRng.AutoFilter Field:=2, Criteria1:="<>"
    sourceRng.Copy Destination.Cells(2, 1)
    Source.AutoFilterMode = False

Upvotes: 1

Related Questions