This page in English Home > Excel VBA makroer > Arrays og ranges

RSS

Arrays og ranges i Excel VBA - slet rækker

De fleste, som kaster sig over VBA og makroer i Excel, lærer hurtigt at bruge ranges, for det er virkelig smart og forholdsvis nemt at gå til.

Denne side viser eksempler på, hvordan man lynhurtigt kan fjerne rækker i et range (en tabel) ved at tage arrays til hjælp, men det kan også være andre opgaver end fjernelse af rækker.

Man kan godt gennemløbe et range og fjerne eller indsætte rækker, men det er bøvlet, fordi ens range pludselig har ændret sig, og hvis man fx fjerner den række, man står i, står man pludselig i det, der før var rækken nedenunder. Det er både nemmere og hurtigere i et array!

Det første eksempel viser, hvordan man kan fjerne hveranden række, og det andet hvordan man kan fjerne rækker nedefra, hvis rækken ovenover har identiske værdier i udvalgte kolonner.

Man kan bruge andre kriterier, og målet behøver ikke være fjernelse af rækker - det er blot mine eksempler. Du kan også downloade et regneark med eksemplerne.

Fordelen ved arrays

Hvis man arbejder med store tabeller, kan man ofte få meget hurtigere kode, hvis man kopierer sit range over i et array og laver operationerne her for dernæst at sætte arrayet ind som en (ny) tabel i ét hug.

Hastighedsforøgelsen skyldes, at der er et meget stort overhead i skrivning til og fra regnearket, mens det går lynhurtigt i et array.

Metoden egner sig ikke til alle opgaver, men jeg tror, at mange tumler med meget store tabeller i Excel (fx logfiler eller rapporter) og ofte har brug for at luge ud i disse data efter helt bestemte retningslinjer.

Hvis det drejer sig om sortering eller filtrering, bør man altid anvende Excels indbyggede funktioner hertil (fx autofilter), da ingen VBA-kode kan måle sig med disse i hastighed; men har man særlige behov, kan VBA være en stor hjælp.

Fjern hveranden række

Det følgende eksempel er forholdsvis enkelt: Det fjerner hveranden række i et range. Om nogen har brug for det, ved jeg ikke, men det illustrerer teknikken uden for meget flimmer.

  1. Kopiér dit range til et todimensionel array i ét hug. Arrayet får automatisk de samme dimensioner som ranget (antal rækker og kolonner).
  2. Kopiér de udvalgte poster (rækker - her hveranden) til et nyt array.
  3. Sæt det nye array ind som en tabel i regnearket i ét hug - altså ikke noget dræbende langsomt gennemløb med celle for celle.

Eksemplet forudsætter, at regnearket med tabellen er aktivt, og at tabellen starter i celle A1. Du kan markere koden med musen, kopiere med CTRL+C og indsætte den i et VBA-modul med CTRL+V. Du kan også downloade et regneark med eksemplerne på denne side. 

Sub FjernHveranden()
'Denne procedure fjerner simpelthen hver
'anden række i en tabel. Først kopieres
'tabellen over i et array, og dernæst
'skrives hvert andet item over i et nyt
'array, som kopieres ind på et nyt faneblad
'i et snuptag.
Dim MyArray() As Variant    'Arrayet
Dim NewArray() As Variant   'Resultatarrayet
Dim rTable As Range         'Rangevariabel
Dim lCount As Long          'Tæller
Dim lCount2 As Long         'Tæller
Dim lCount3 As Long         'Tæller
Dim lRows As Long           'Antal rækker
Dim lCols As Long           'Antal kolonner
Dim lNewRows As Long        'Antal rækker i nyt array

On Error GoTo ErrorHandle

'Slår skærmopdatering fra
Application.ScreenUpdating = False

If Len(Range("A1")) = 0 Then
   MsgBox "Celle A1 er tom. Eksemplet forudsætter " & _
   "at tabellen starter i celle A1."
   GoTo BeforeExit
End If

'Sætter rTable = tabellen. "CurrentRegion" er bekvem,
'når tabellen er afgrænset af tomme celler. Hvis den
'støder op til celler med indhold, som ikke hører til
'tabellen, må man definere sit range på en anden måde.
'Her antages, at tabellen starter i celle A1.
Set rTable = Range("A1").CurrentRegion

'Tabellen kopieres til MyArray i ét hug. Bemærk, at vi ikke
'gennemløber celle for celle og udfylder arrayet, element
'for element, men simpelthen tager "en kopi" af ranget i
'én operation.
MyArray = rTable.Value

'Antal rækker og kolonner i tabellen gemmes i variablerne
'lRows og lCols.
With rTable
   lRows = .Rows.Count
   lCols = .Columns.Count
End With

'Før vi dimensionerer det nye array, som skal indeholde
'den "rensede" tabel, skal vi finde ud af, hvor mange
'rækker det skal have, og det afhænger af, om der er et
'lige eller ulige antal i udgangstabellen.
If lRows Mod 2 = 0 Then
   lNewRows = lRows / 2
Else
   lNewRows = lRows / 2 + 1
End If

'Det nye array dimensioneres, så det har det antal
'rækker, som ikke slettes. Antallet af kolonner er uændret.
ReDim NewArray(lNewRows, lCols)

'Nu gennemløbes det gamle array, og de "ulige" rækker
'kopieres til det nye array. Bemærk, at vi bruger "Step 2"
'for at få hveranden. Den ydre løkke finder rækkerne
'og den indre løkke kopierer cellernes indhold fra venstre
'mod højre.
For lCount = 1 To lRows Step 2
   lCount2 = lCount2 + 1
   'Nu kopieres rækkens celler fra venstre mod højre
   For lCount3 = 1 To lCols
      NewArray(lCount2, lCount3) = MyArray(lCount, lCount3)
   Next
Next

ReDim Preserve NewArray(lNewRows, lCols)

'Et nyt faneblad tilføjes
Sheets.Add

'rTable dimensioneres til samme størrelse som NewArray
Set rTable = Range("A1").Resize(lNewRows, lCols)

'Den sorterede tabel indsættes i ét hug. Altså ikke noget
'med at gennemløbe arrayet og udfylde celle for celle.
'Ved at gøre det hele i én operation spares bunker af tid.
rTable.Value = NewArray

BeforeExit:
Set rTable = Nothing
'Slår skærmopdatering til
Application.ScreenUpdating = True

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Fejl i procedure FjernHveranden."
Resume BeforeExit
End Sub

Sletning af identiske rækker i en tabel

Det næste eksempel er lidt mere kompliceret, men nok også mere brugbart. Det viser, hvordan man kan slette rækker ved at bruge bestemte kriterier.

Konkret bruger jeg makroen til at luge ud i døgnrapporter med kemiske analyser. Det er ikke alle produkter, der analyseres hver time, og hvis der ikke er kommet en ny analyse kl. xx, vil den sidste blive gentaget i døgnrapporten for den pågældende time.

Døgnrapporten har 24 rækker, en for hver time, og i min tabel kan jeg fx have døgnrapporter for et helt år.

For kun at have unikke analyser ønsker jeg altså at fjerne de rækker, som blot er en gentagelse af rækken ovenover. Hvis anlægget fx er stoppet, optræder den samme analyse måske i dagevis, og det er ikke smart, hvis man skal se på spredning og den slags.

I punktform sker der følgende:

  1. Tabellen defineres som et range (her: rTable). I eksemplet forudsættes, at tabellen er i det aktive faneblad, og at tabellen starter i celle A1.
  2. Ranget kopieres over i et array, MyArray, i ét hug.
  3. Brugeren bliver bedt om at udpege den eller de kolonner, som skal bruges i sammenligningen - altså hvilke kolonner er afgørende for, om rækken er identisk med rækken ovenover.
  4. Arrayet gennemløbes række for række nedefra, og hvis en række er en kopi, indsættes et mærke (her ordet "slet") i det der svarer til første celle i rækken.
  5. Et nyt array, NewArray, defineres.
  6. Alle elementer i MyArray som ikke indeholder ordet "slet" i første kolonne kopieres over i NewArray.
  7. Det nye array med den "rensede" tabel indsættes i ét hug på et nyt faneblad.

Du kan markere koden med musen, kopiere med CTRL+C og indsætte den i et VBA-modul med CTRL+V. Du kan også downloade et regneark med eksemplerne på denne side.

Here we go:

Sub FjernDubletter()
'Finder og fjerner rækker, som indeholder data,
'der er identiske med rækken oven over. Det kan
'fx være tilfældet med laboratoriedata, hvor
'den gamle analyse går ind i døgnrapporten
'(ny time), hvis der ikke er kommet en ny.
Dim bSame As Boolean        'Flag
Dim MyArray() As Variant    'Arrayet
Dim NewArray() As Variant   'Resultatarrayet
Dim rCell As Range          'Rangevariabel
Dim rTable As Range         'Rangevariabel
Dim rIsect As Range         'Rangevariabel
Dim lRows As Long           'Antal rækker
Dim lCols As Long           'Antal kolonner
Dim lCount As Long          'Tæller
Dim lCount2 As Long         'Tæller
Dim lCount3 As Long         'Tæller
'colColumns holder styr på de brugervalgte
'kolonnenumre, hvor data skal sammenlignes.
Dim colColumns As Collection

On Error GoTo ErrorHandle

If Len(Range("A1")) = 0 Then
   MsgBox "Celle A1 er tom. Eksemplet forudsætter " & _
   "at tabellen starter i celle A1."
   GoTo BeforeExit
End If

'Sætter rTable = tabellen. "CurrentRegion" er bekvem,
'når tabellen er afgrænset af tomme celler. Hvis den
'støder op til celler med indhold, som ikke hører til
'tabellen, må man definere sit range på en anden måde.
'Her antages, at tabellen starter i celle A1.
Set rTable = Range("A1").CurrentRegion

'Tabellen (ranget) kopieres til MyArray
MyArray = rTable.Value

On Error Resume Next

'Brugeren skal nu udpege kolonnerne med
'værdierne, som skal sammenlignes. Det er
'nok at markere en celle i hver kolonne.
Set rCell = Application.InputBox(prompt:="Markér de kolonner" & _
" som skal bruges i sammenligningen. Det er nok at markere " & _
"én celle i hver kolonne.", Type:=8)

'Hvis brugeren annullerer og ikke vælger kolonner, afbrydes.
If rCell Is Nothing Then
   MsgBox "Der blev ikke valgt kolonner - programmet afbrydes."
   GoTo BeforeExit
End If

On Error GoTo ErrorHandle

'Slår skærmopdatering fra
Application.ScreenUpdating = False

'Hvis det valgte område er uden for tabellen stoppes.
Set rIsect = Application.Intersect(rCell, rTable)
If rIsect Is Nothing Then
   MsgBox "Det valgte område er uden for tabellen"
   GoTo BeforeExit
End If

'colColumns initialiseres. Om collections se min side:
'Collections
Set colColumns = New Collection

'Nu findes de valgte cellers kolonnenumre i tabellen (rTable).
'Disse numre skal bruges, når vi gennemløber og sammenligner
'værdierne i arrayet MyArray.
With rTable
   For lCount = 1 To .Columns.Count
      Set rIsect = Application.Intersect(rCell, .Columns(lCount))
      If Not rIsect Is Nothing Then
         'Kolonnenummeret gemmes i colColumns.
         colColumns.Add lCount
      End If
   Next
End With

'Antal rækker og kolonner i tabellen gemmes
i variablerne lRows og lCols.
With rTable
   lRows = .Rows.Count
   lCols = .Columns.Count
End With

lSlet = 0

'Nu gennemløbes arrayet, og poster, som skal slettes,
'får ordet "slet" i første item. Vi gennemløber nede
'fra og stopper i række 2, da række 1 i sagens natur
'ikke har nogen "forgænger".
For lCount = lRows To 2 Step -1
   bSame = True
   With colColumns
      For lCount2 = 1 To .Count
         'Hvis data er forskellige sættes bSame = false
         If MyArray(lCount, .Item(lCount2)) <> _
            MyArray(lCount - 1, .Item(lCount2)) Then
            bSame = False
            Exit For
         End If
      Next

      'Hvis data er identiske, er bSame = True,
      'og posten mærkes med ordet "slet" i første item.
      If bSame Then
         MyArray(lCount, 1) = "slet"
         lSlet = lSlet + 1
      End If
   End With
Next

lCount2 = 0
lSlet = lRows - lSlet

'Det nye array dimensioneres, så det har samme antal
'rækker som det gamle minus antal rækker, som skal
'slettes. Antallet af kolonner er uændret.
ReDim NewArray(lSlet, lCols)

'Nu gennemløbes det gamle array, og poster, som
'ikke har ordet "slet" i første item, kopieres
'til det nye array.
'Den ydre løkke gennemløber rækkerne, og den indre
'kopierer fra venstre mod højre, når en ny række er
'tilføjet NewArray.
For lCount = LBound(MyArray) To UBound(MyArray)
   If MyArray(lCount, 1) <> "slet" Then
      lCount2 = lCount2 + 1
      'Nu kopieres fra venstre mod højre.
      For lCount3 = 1 To lCols
         NewArray(lCount2, lCount3) = MyArray(lCount, lCount3)
      Next
   End If
Next

ReDim Preserve NewArray(lSlet, lCols)

'Et nyt faneblad tilføjes
Sheets.Add

'Vi definerer et range, rCell, som dimensioneres
'til samme størrelse som NewArray
Set rCell = Range("A1").Resize(lSlet, lCols)

'Den sorterede tabel indsættes i ét hug.
rCell.Value = NewArray

BeforeExit:
'Vi sætter vores objekter til Nothing
'for at spare hukommelse.
Set rCell = Nothing
Set rTable = Nothing
Set rIsect = Nothing
Set colColumns = Nothing
'Slår skærmopdatering til
Application.ScreenUpdating = True

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Fejl i procedure FjernDubletter."
Resume BeforeExit
End Sub

Relateret: