Home » excel » excel – vba, copy data from sparse column to form a new dense column

excel – vba, copy data from sparse column to form a new dense column

Posted by: admin May 14, 2020 Leave a comment


An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.

My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.

Sub CopyFromMultipleRanges()

With Worksheets("Page1")

.Range("A1:A5").Value = 1

.Range("A8:A10").Value = 2

Dim c_cell As Range
Dim j As Long

j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
    Worksheets("Page2").Range("A" & j).Value = c_cell.Value
    j = j + 1

End With


End Sub

Initial column where data is sparse.

Final dense data column.

How to&Answers:

You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range

Sub Delete_Blank_Rows()

On Error Resume Next

End Sub


Here’s how I would do it:

'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant

'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")

With ws1
    size = .UsedRange.Rows.Count

    'loop through the range to pick up the data from non-empty cells
    For i = 1 To size
        'if the cell is not empty, then add the value to the collection
        If Not IsEmpty(.Cells(i, 1).Value) Then
            bin.Add .Cells(i, 1).Value
        End If 

    'loop through the bin contents
    i = 1
    For Each v In bin
        ws2.Cells(i, 1).Value = v
        i = i + 1
End With

Hope it helps!


I tested this code and it works:

Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
    Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)

    ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub

you can read more about Range.SpecialCells here. learn something new everyday!


This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that “A1:A5” and “A8:A10” is indeed “A1:A10”.

Option Explicit
Public Sub CopyFromMultipleRanges()
    Dim rng As Range:  Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
    Application.ScreenUpdating = False
    If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
    With rng
        .AutoFilter 1, "<>"
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
    Application.ScreenUpdating = True
    End With
End Sub