autofiltrerede celler ind i array

Som en test har jeg prøvet at gøre sådan her, men får at vide at der er er en objekt variabel eller en With block variabel der ikke er sat.

Sub SetActive()
    Dim x As Variant
   
  Worksheets("Ark1").Select
  For Each x In ActiveSheet.AutoFilter.range.Rows
        y = y + 1
        Worksheets("Ark2").Cells(y, 1) = x(1, 1)
  Next
End Sub

Jeg har fundet ud af at man nok på en eller anden måde kan bruge xlCellTypeVisible, men hvordan ved jeg ikke....

En ugly fuckly kode, men det virker:


Function CopyFilter(readSheet, height, width)
    Dim End_row As Long
    Dim y As Long
    Dim RowArray() As Variant
    Dim DimY() As Variant
    Dim DimX() As Variant
    Dim r2 As Integer
   
    ReDim DimY(height)
    ReDim DimX(width)
   
    r2 = 1
    For r = 2 To height
        If Sheets(readSheet).Rows(r).Hidden = False Then
            Sheets("Ark2").Rows(r2).Value = Sheets(readSheet).Rows(r).Value
            r2 = r2 + 1
        End If
    Next
   
    For y = 1 To height
        For x = 1 To width
            DimX(x) = Worksheets("Ark2").Cells(y, x)
        Next
        DimY(y) = DimX()
    Next
    For y = 1 To height
        For x = 1 To width
            Worksheets("Ark3").Cells(y, x) = DimY(y)(x)
        Next
        DimY(y) = DimX()
    Next
   
    CopyFilter = DimY()
   
End Function

Men er ustyrligt langsom i Office 2007

Function CopyFilter(readSheet, height, width)
    Dim End_row As Long
    Dim y As Long
    Dim RowArray() As Variant
    Dim DimY() As Variant
    Dim DimX() As Variant
    Dim r2 As Integer
   
    ReDim DimY(height)
    ReDim DimX(width)
   
    newY = 1
    For y = 2 To height
        If Sheets(readSheet).Rows(y).Hidden = False Then
            Sheets("Ark2").Rows(newY).Value = Sheets(readSheet).Rows(y).Value
            For x = 1 To width
                DimX(x) = Sheets(readSheet).Cells(y, x)
            Next
            DimY(y) = DimX()
            newY = newY + 1
        End If
    Next
   
    CopyFilter = DimY()
   
End Function

Er stadig ustyrligt langsomt........

Sådan, så kører det hurtigt, havde lige glemt at fjerne en linie:

Function CopyFilter(readSheet As String, height As Long, width As Long)
    Dim RowArray() As Variant
    Dim DimY() As Variant
    Dim DimX() As Variant
    Dim r2 As Integer
   
    ReDim DimY(height)
    ReDim DimX(width)
   
    newY = 1
    For y = 2 To height
        If Sheets(readSheet).Rows(y).Hidden = False Then
            For x = 1 To width
                DimX(x) = Sheets(readSheet).Cells(y, x)
            Next
            DimY(y) = DimX()
            newY = newY + 1
        End If
    Next
   
    CopyFilter = DimY()
   
End Function