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

Questions:

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
Next

End With

Worksheets("Page2").Activate

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
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Answer:

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 
    Next

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

Hope it helps!

Update:

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!

Answer:

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
        .AutoFilter 1, "<>"
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
        .AutoFilter
    Application.ScreenUpdating = True
    End With
End Sub