Question

我有下面的宏，该宏将已过滤的数据复制并粘贴到已过滤的单元格上，但是它仅在我从一列中选择数据时起作用。当我尝试一系列多列时，它将数据复制回单列并粘贴，如下所示：column1V1，column1V2，column1V3等

请帮助我完成这项工作，以便将过滤后的数据以相同的顺序/格式粘贴到其他列中

Sub Filtered_Cells()

    Dim from As Range

    Set from = Application.InputBox("Select range to copy selected cells to", Type:=8)

    from.Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Call Copy_Filtered_Cells

End Sub

Sub Copy_Filtered_Cells()

    Set from = Selection
    Set too = Application.InputBox("Select range to copy selected cells to", Type:=8)

    For Each Cell In from
        Cell.Copy
        For Each thing In too
            If thing.EntireRow.RowHeight > 0 Then
                thing.PasteSpecial
                Set too = thing.Offset(1).Resize(too.Rows.Count)
                Exit For
            End If
        Next
    Next

End Sub

Answer 1

这对您有用吗？

Sub Copy_Filtered_Cells_New()

Dim from As Range, too As Range, fromRng As Range
Set from = Application.InputBox("Select range to copy cells from", Type:=8)
Set too = Application.InputBox("Select range to paste cells to", Type:=8)
Dim ws As Worksheet: Set ws = from.Worksheet
Dim arrRanges() As String: arrRanges = Split(from.SpecialCells(xlCellTypeVisible).address, ",")

Dim R As Long, X As Long, nextVisRow As Long

    For X = LBound(arrRanges) To UBound(arrRanges)  'For each visible range
        Set fromRng = ws.Range(arrRanges(X))
        With fromRng
            For R = 1 To .Rows.Count  'For each row in the selected range
                nextVisRow = NextVisibleRow(too.Cells(1, 1)) 'Get the next visible row for paste

                too.Offset(nextVisRow - too.row).Resize(1, .Columns.Count).Value = .Offset(R - 1).Resize(1, .Columns.Count).Value
                Set too = too.Offset(nextVisRow - too.row + 1)
            Next R
        End With
    Next X

End Sub

Function NextVisibleRow(rng As Range) As Long

Dim ws As Worksheet: Set ws = rng.Worksheet
Dim R As Long: R = rng.Cells(1, 1).row

    Do While True
        If Not ws.Rows(R).EntireRow.Hidden Then
            NextVisibleRow = R
            Exit Do
        End If
        R = R + 1
    Loop

End Function

Answer 2

感谢用户FAB，我得以进一步开发该宏。现在，它可以将任何范围的可见单元格复制到任何可见数据，而没有任何限制或问题。问题在于数组无法“记录”超过18个左右的元素。我使用了将用户选择的数据复制到新表的技巧，该表可以成功归因于数组。这是完成的代码。

Public copyRng As Range
Public wb As Workbook

Sub Copy_Paste_Filtered_Data()

Copy

Dim from As Range, too As Range, fromRng As Range
Set from = copyRng
Set too = Application.InputBox("Select range to paste cells to", Type:=8)
Dim ws As Worksheet: Set ws = from.Worksheet
Dim arrRanges() As String: arrRanges = Split(from.SpecialCells(xlCellTypeVisible).Address, ",")

Dim R As Long, X As Long, nextVisRow As Long

    For X = LBound(arrRanges) To UBound(arrRanges)  'For each visible range
        Set fromRng = ws.Range(arrRanges(X))
        With fromRng
            For R = 1 To .Rows.Count  'For each row in the selected range
                nextVisRow = NextVisibleRow(too.Cells(1, 1)) 'Get the next visible row for paste

                too.Offset(nextVisRow - too.Row).Resize(1, .Columns.Count).Value = .Offset(R - 1).Resize(1, .Columns.Count).Value
                Set too = too.Offset(nextVisRow - too.Row + 1)
            Next R
        End With
    Next X

wb.Activate
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True

End Sub

Function NextVisibleRow(rng As Range) As Long

Dim ws As Worksheet: Set ws = rng.Worksheet
Dim R As Long: R = rng.Cells(1, 1).Row

    Do While True
        If Not ws.Rows(R).EntireRow.Hidden Then
            NextVisibleRow = R
            Exit Do
        End If
        R = R + 1
    Loop

End Function

Public Function Copy()

Dim ws As Worksheet
Set wb = Workbooks("PERSONAL.XLSB")
Set copyRng = Application.InputBox("Select range to copy cells from", Type:=8)
copyRng.Select
Selection.Copy
    With wb
            Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            ws.Name = "Temp"
    End With
wb.Activate
Range("A1").Select
ActiveSheet.Paste
Set copyRng = Selection

End Function

这使用了“ PERSONAL.XLSB”工作簿，因此在使用此宏之前，请确保先在其中记录一个宏，然后将其激活

将范围粘贴到可见细胞

2 个答案: