RSS

Betinget kopiering af rækker i tabel

Et ofte stillet spørgsmål er, hvordan man kopierer eller udtrækker rækker fra en tabel til en anden (måske i et andet regneark), hvis rækkerne opfylder et eller andet kriterium.

Betingelsen for at kopiere kan være et kundenummer, et serienummer, et navn, et mønster med "jokere" eller hvad ved jeg.

Denne side viser et eksempel på en hurtig Excel VBA makro, som gør netop det.

Makroen antager, at værdien/teksten, der skal matche, står i tabellens første kolonne (her A), men det kan nemt ændres.

Makroen har følgende trin:

  1. Brugeren skal skrive søgestrengen (eller mønstret) i en inputbox. Hvis du altid bruger samme identifikator, bør du skippe inputboksen og deklarere en konstant i stedet.
  2. Inputtabellen defineres som et range.
  3. Tabellens (rangets) indhold kopieres til et array i ét hug. Grunden til at bruge arrays er enkel: hastighed!
  4. Makroen gennemløber arrayet og kopierer rækker, som opfylder betingelsen, til et andet array.
  5. Når gennemløbet er færdigt, åbnes et nyt regneark, og output-arrayet med de kopierede rækker indsættes som en tabel startende i celle A1. I stedet for at åbne et nyt regneark, er det nemt at ændre til et andet faneblad eller et specifikt regneark.

Makroen kopierer ikke hele rækken fra det originale faneblad - den kopierer kun rækken fra tabellen med det antal kolonner, den nu indeholder.

Makroen er hurtig, fordi den opererer på arrays og kun opererer direkte på regnearket to gange: Når tabellen defineres som range og værdierne kopieres til input-arrayet, og når den nye tabel defineres og output-arrayet indsættes i ét hug.

Det ville være meget langsommere at gennemløbe ranget og kopiere rækkerne på "konventionel" vis, fordi enhver operation direkte på regnearket har et stort overhead.

Like-sammenligning

Makroen bruger "Like-operatoren" til at finde de rækker, som skal kopieres. Den kan finde værdier, der matcher eksakt, men den kan også finde mønstre ved at bruge "jokere".

Fx vil "2*e" finde alle værdier, som begynder med "2" og slutter med "e". De mulige jokere er:

  • ? Enhver enkel karakter
  • * Nul eller flere karakterer
  • # Ethvert enkelt tal (0–9)
  • [liste] Enhver enkelt karakter i liste
  • [!liste] Enhver enkelt karakter IKKE i liste

VBA bruger som standard binær sammenligning og skelner således mellem store og små bogstaver. Vil man ikke skelne mellem store og små bogstaver (altså A=a, B=b osv.), skal man deklarere "Option Compare Text" på modulniveau (øverst i VBA-modulet).

Se VBA's hjælp for mere info om Like-operatoren.

Makroen antager, at udgangstabellen starter i celle A1 på det aktive ark, og den definerer ranget med "CurrentRegion". Hvis din tabel indeholder blanke rækker eller kolonner, eller hvis den ikke afgrænses af sådanne, skal du definere ranget på en anden måde.

Lad os komme i gang. Vil du prøve makroen, kan du markere den med musen, kopiere (CTRL+C) og sætte den ind (CTRL+V) i et VBA-modul.


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

Det var det. Du kan bruge en lignende teknik til at slette rækker eller til at flette data.

Den vigtigste pointe er næsten, at du får meget hurtigere kode, hvis du opererer på arrays og begrænser direkte operationer på selve regnearket (læsning/skrivning) mest muligt.

Nederst finder du links til sider med relateret indhold.

Relateret: