在链接另一个单元格参考时将非空白单元格从工作表复制到另一个单元格

Question

我想将特定范围 (A2:B50) 从工作表 1 复制到工作表 2，同时忽略空白单元格。并在每列粘贴 x 行后在位于 B1 的两张表之间添加一个键。例如：

在 Sheet2 中变成这个：

在每个副本上，如果我想添加新数据，它将添加到 Sheet2 中现有数据的顶部。

这是我的代码，它不能按预期工作，有什么帮助吗？

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

Answer 1

未经测试，但试试这个：

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

已编辑 - 对于任何指定数量的源列：

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