Betinget kopiering af rækker i tabel

Sub CopyRows()
Dim lRow As Long           'Tæller
Dim lCol As Long           'Tæller
Dim lCount As Long         'Tæller
Dim rInputTable As Range   'Inputtabellen
Dim rTarget As Range       'Outputtabellen
Dim arInput()              'Array med inputtabellen
Dim arOutput()             'Array til outputtabellen
Dim vPattern As Variant    'Søgekriterium/mønster

On Error GoTo ErrorHandle

'Vi beder brugeren angive identifikatoren eller møntret,
'som skal matche.
vPattern = InputBox("Angiv søgestreng/værdi" & vbNewLine _
& "Du kan bruge jokere til mønstre:" & vbNewLine & vbNewLine _
& "?   Enhver enkelt karakter" & vbNewLine _
& "*   Nul eller flere karakterer" & vbNewLine _
& "#   Ethvert enkelt tal (0-9)" & vbNewLine _
& "[liste]   Enhver enkelt karakter i liste" & vbNewLine _
& "[!liste]  Enhver enkelt karakter IKKE i liste", "Identifikator")

'Hvis brugeren trykkede cancel eller ikke skrev noget, afbrydes.
If Len(vPattern) = 0 Then Exit Sub

'Du kan definere input-tabellen som du vil.
'Her bruges A1's CurrentRegion.
'"CurrentRegion" er et range afgrænset af
'tomme rækker og tomme kolonner, så den er
'bekvem, hvis tabellen ikke indeholder
'tomme rækker eller kolonner.
Set rInputTable = Range("A1").CurrentRegion

'Kopierer tabellen til arrayet arInput.
'Arrayet får automatisk de samme dimensioner
'som tabellen. Grunden til at bruge et array
'er simpelthen højere hastighed.
arInput = rInputTable.Value

'Tabellens indhold er nu kopieret til arrayet, og
'vi skal ikke bruge den mere, så vi sætter ranget
'til Nothing for at spare hukommelse.
Set rInputTable = Nothing

'Redimensionerer output-arrayet til samme størrelse
'(rækker og kolonner) som input-arrayet.
'Det vil næsten altid være større end nødvendigt,
'men medmindre du har begrænset plads til rækkerne,
'der kopieres, er det ligegyldigt, fordi de nederste
'rækker vil være tomme.
'Hvis du vil begrænse størrelsen på output-tabellen,
'kan du gennemløbe input-arrayet to gange. Første
'gang for at tælle antallet af rækker, som skal
'kopieres, og så bruge den værdi til at dimensionere
'output-arrayet.
'1 To UBound(arInput) er antallet af rækker, og
'1 To UBound(arInput, 2) er antal kolonner.
ReDim arOutput(1 To UBound(arInput), 1 To UBound(arInput, 2))

'Gennemløb input-arrayet og kopier rækker, som
'matcher identifikatoren eller mønstret.
For lRow = 1 To UBound(arInput)
   'Vi bruger "Like-operatoren" til at sammenligne
   'i stedet for "=". Det tillader brugen af jokere/mønstre.
   'Koden antager, at identifikatoren står i tabellens
   'første kolonne (her A), men det kan nemt ændres.
   'Så skal du bare være sikker på, at kolonnen findes
   'i tabellen, for ellers får du en fejl.
   If arInput(lRow, 1) Like vPattern Then
      'Hvis værdien matcher, lægger vi 1 til tælleren lCount
      'og kopierer rækken til output-arrayet
      lCount = lCount + 1
      
      'Alle celleværdier til højre for den første
      'kopieres. Vil du ikke have alle kolonner med,
      'skal du angive et kolonnenummer i stedet for:
      'UBound(arInput, 2)
      For lCol = 1 To UBound(arInput, 2)
         arOutput(lCount, lCol) = arInput(lRow, lCol)
      Next
   End If
Next

'Hvis lCount er nul, var der ingen rækker, som matchede.
If lCount = 0 Then
   MsgBox "Ingen rækker opfyldte søgekriteriet."
   GoTo BeforeExit
End If

'I dette eksempel åbner vi et nyt regneark og kopierer
'output-arrayet ind som en tabel startende i celle A1.
'Selvfølgelig kan du definere en anden destination, fx
'et specifikt regneark eller bare et andet faneblad.
Workbooks.Add

'Dimensionerer et range til samme størrelse som output-arrayet.
Set rTarget = Range("A1").Resize(UBound(arOutput), UBound(arOutput, 2))

'Kopierer arrayet til ranget i ét hug.
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