VB til at sortere data i en kolonne og flytte bruge definerede kolonne til et nyt faneblad.

Hej alle sammen

Sidste uge spurgte jeg om hvordan jeg kopierer de bestemte kolonne fra et Excel faneblad til et nyt. Denne proces var uden sortering: bare kopiere-og-indsæt. Men jeg er meget taknemlig for pointering på mine fejl og makro rettelsen. Så arbejder jeg på en anden makro hvor jeg skal sortere først en kolonne hvorefter kopirere bestemte kolonner.

Beskrivelsen: i fanebladet test har jeg et stort datasæt i A1:AW. Række 1 står for kolonnernes navner. I kolonnen V (lRow, 22) af det oprindelige data fra test står tre kriterier: Compliance1, Compliance2, Ingen.

Formålet med makroen: først via Input Box brugen vælger et af de compliance niveauer, hvorefter et array med bestemte kolonner defineres. Efter definerer jeg rå data området og resizer det med de brugen-definerede kolonner. Så kører jeg loop på de bestemte række i kolonne 22 af den rå data og tæller dem hvis de matcher vPattern (den valgte kriterier), og de kolonner som jeg gerne vil have kopieres (fra myColArray). Til sidst tilføres der et faneblad med vPatterns navn hvor det sorterede array vil ligge.

Problemstilling: I det nye faneblad kopires bare kolonner fra min rå data fra A til F kolonner, og jeg aner ikke hvad jeg gør forket. Jeg prøvede at bruge InStr funktionen men det hjælper ikke. Det må være at jeg definere noget forket.
Er der nogen der kan kigger på min makro og rette den op, så ville det være en stor hjælp.
På forhånd tak for hjælpen.

Sub CompliancesTabels_1_2_No()

    Dim lRow As Long
    Dim lCol As Long
    Dim lCount As Long
    Dim rInputTable As Range
    Dim rTarget As Range
    Dim arInput()
    Dim arOutput()
    Dim vPattern As Variant

    On Error GoTo ErrorHandle

    vPattern = InputBox("Angiv complience gruppe", "Identifikator")
    If Len(vPattern) = 0 Then Exit Sub

    Dim myColArray As Variant
    myColArray = Array(19, 20, 18, 31, 28, 41)

    Set rInputTable = Sheets("test").Range("A1").CurrentRegion
    arInput = rInputTable.Value
    Set rInputTable = Nothing
    ReDim arOutput(1 To UBound(arInput), 1 To UBound(myColArray))

    For lRow = 1 To UBound(arInput)
        If arInput(lRow, 22) Like vPattern Then
        'If InStr(1, UCase(rInputTable(lRow, 22)), vPattern) > 0 Then
        lCount = lCount + 1
        For lCol = 1 To UBound(myColArray)
            arOutput(lCount, lCol) = arInput(lRow, lCol)
        Next
        End If
    Next


    If lCount = 0 Then
        MsgBox "Ingen rækker opfyldte søgekriteriet."
        GoTo BeforeExit
    End If

Worksheets.Add.Name = vPattern
Set rTarget = Range("A1").Resize(UBound(arOutput), UBound(arOutput, 2))
rTarget.Value = arOutput

BeforeExit:
On Error Resume Next
Set rTarget = Nothing
Erase arInput
Erase arOutput

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure CopyRows"
Resume BeforeExit
End Sub