时间戳

首页 > 解决方案 > 以相同的顺序/格式粘贴列中过滤数据的范围

excel - 以相同的顺序/格式粘贴列中过滤数据的范围

问题描述

当我从一列中选择数据时，我有下面的工作代码将过滤的数据复制到过滤的单元格。

当我尝试一系列多列时，它会将数据复制回单列并粘贴如下：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

标签： excelvba

解决方案

感谢用户 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”工作簿，因此请务必先在其中记录一个宏，以激活它，然后再使用此宏

推荐阅读