Copying non blank cells from sheet to another while linking another cell ref-CodePudding

I want to copy a specific range (A2:B50) from sheet1 to sheet 2 while ignoring blank cells. And add a Key between both sheets which is located in B1 after each column pasted for x rows. For example:

to become this in Sheet2:

And upon each copy, if I wanted to add new data, it will add on top of the existing data in Sheet2.

This is my code and it does not work as intended, any assistance?

With Sheets("Sheet1").Range("A3:B11")

.AutoFilter 1, "<>"

Dim cel As Range
For Each cel In .SpecialCells(xlCellTypeVisible)

    Sheets("Sheet2").Range("A" & cel.Row).Value = cel.Value

Next

.AutoFilter

End With

CodePudding user response：

Untested, but try this:

Sub Tester()

    Dim lRw As Long, rw As Long, wsSrc As Worksheet, wsDest As Worksheet
    Dim cDest As Range, v, v2, k
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1")  'or activeworkbook
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
    'next empty row on destination sheet (in "key" column, but offsetting to A))
    Set cDest = wsDest.Cells(Rows.Count, 3).End(xlUp).Offset(1, -2)
    k = wsSrc.Range("B1").Value 'key value
    
    lRw = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row 'last row of source data
    For rw = 3 To lRw
        v = wsSrc.Cells(rw, 1).Value
        v2 = wsSrc.Cells(rw, 2).Value
        If Len(v) > 0 Or Len(v2) > 0 Then  'if either cell has a value 
            cDest.Value = v                'write values
            cDest.Offset(0, 1).Value = v2
            cDest.Offset(0, 2).Value = k   'write key
            Set cDest = cDest.Offset(1, 0) 'next destination row
        End If
    Next rw
End Sub

Edited - for any specified number of source columns:

Sub Tester()
    Const NUM_COLS As Long = 3 'or whatever
    
    Dim lRw As Long, rw As Long, wsSrc As Worksheet, wsDest As Worksheet
    Dim cDest As Range, k
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1")  'or activeworkbook
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
    'next empty row on destination sheet (in "key" column, but offsetting to A))
    Set cDest = wsDest.Cells(Rows.Count, NUM_COLS   1).End(xlUp).Offset(1, -NUM_COLS)
    
    k = wsSrc.Range("B1").Value 'key value
    
    lRw = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row       'last row of source data
    For rw = 3 To lRw                                      'loop over source rows
        With wsSrc.Cells(rw, 1).Resize(1, NUM_COLS)
            If Application.CountA(.Cells) > 0 Then         'if any cell has a value
                cDest.Resize(1, NUM_COLS).Value = .Value   'write values
                cDest.Offset(0, NUM_COLS).Value = k        'write key
                Set cDest = cDest.Offset(1, 0)             'next destination row
            End If
        End With
    Next rw
End Sub