Вставить диапазон отфильтрованных данных в столбцах в том же порядке / формате

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

Благодаря пользователю 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", поэтому обязательно сначала запишите в нее макрос, чтобы активировать его, прежде чем использовать этот макрос

Answer 2

Будет ли это работать для вас?

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