转置可见细胞直到最后一列

Question

I've an excel sheet which basically will have a variable numbers in Columns A till C, it gets filtered to unique values based on for next loop I've achieved this and next I'm trying to copy the visible range starting from column F till last column (since variable columns each time when filters) and transpose it vertically in new sheet.The approach that I've used is counting each visible row and copy till end. Here's the code.

Set ws = ActiveSheet
Set WS2 = ThisWorkbook.Sheets("3")
L2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
For Each CELL In ws.Range("F2:F" & L2).SpecialCells(xlCellTypeVisible)
    i = CELL.Row
    L3 = ws.Cells(i, Columns.Count).End(xlToLeft).Column
    ws.Range(Cells(i, 6), Cells(i, L3)).Copy
    L4 = WS2.Cells(Rows.Count, 4).End(xlUp).Row
    WS2.Cells(L4 + 1, 4).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next CELL

But is there any alternate way to copy and transpose cells that have values from Column F till last column?In the above example starting from F108:H110 select and copy only cells that have values in it.

Answer 1

SpecialCells is a member of Range returns a range Object. Knowing that we can chain them together .SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) to narrow our range. This will give you a non-continuous range. You cannot use the copy command with a Non-continuous. If you assign it to an array, the array will only be partially populated. You must iterate over it with a For Each loop.

Sub SelectVisibleNonBlankCells()
    Dim c As Range, r As Range
    Dim L2 As Long

    With ThisWorkbook.Sheets("3")

       L2 = .Cells(Rows.Count, 1).End(xlUp).Row
       Set r = .Range("F2:F" & L2).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants)

    End With

    For Each c In r

    Next

End Sub

I would just iterate over the all the rows checking for visibility. Next just add the data to an an array and use range resize to fill the destination range.

Sub TransposeVisibleCells()

    With ThisWorkbook.Sheets("3")
        Dim ColumnCount As Integer, lastRow As Long, RowCount As Long, x As Long, y As Long
        Dim arData

        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        ColumnCount = .Cells(1, Columns.Count).End(xlToLeft).Column

        ReDim arData(ColumnCount, RowCount)
        For x = 2 To lastRow

            If Not .Rows(x).Hidden Then
                ReDim Preserve arData(ColumnCount, RowCount)

                For y = 1 To ColumnCount
                    arData(y -1, RowCount) = .Cells(x, y).Value
                Next

                RowCount = RowCount + 1
            End If
        Next

    End With

    Worksheets("Transposed Data").Range("A1").Resize(ColumnCount, RowCount) = arData
End Sub