RSS

Flette og kombinere data og tabeller i Excel med VBA makroer

På denne side viser jeg eksempler på, hvordan man kan flette og kombinere data og tabeller efter bestemte kriterier. Du kan også downloade regneark med eksemplerne.

  • I det første eksempel flettes 2 tabeller/lister til 1 uden dubletter. Den nye tabel sorteres og indsættes i et nyt regneark.
  • I det andet eksempel gennemløbes 2 lister, og der laves 2 nye: En med de værdier som optræder på begge lister, og en med de værdier som kun er på én af listerne.
  • I det tredje eksempel viser jeg, hvordan man kan kombinere rækker i 2 tabeller (i 2 forskellige regneark), hvis de har en fælles værdi - her et firmanavn. Den nye tabel indsættes i et nyt regneark.

Eksemplerne gør bl.a. brug af arrays, ranges, collections, regnearksfunktionen "CountIf" (Tæl.Hvis) og løkker.

Flet til 1 tabel uden dubletter

Dette eksempel forudsætter, at der er nogle værdier (tekst eller tal) i celle A1 og nedad på faneblad 1 og 2. Du kan kopiere koden ved at markere den med musen, trykke CTRL+C og sætte den ind i et VBA-modul med CTRL+V.

Hvis du læser dette på en lille skærm, kan nogle af kodelinjerne være ombrudte, men indsætter du det kopierede i et VBA-modul, er linjeskiftene OK.

Du kan også downloade et zip-komprimeret regneark (Excel 2003) med dette og det næste eksempel.

Koden samler værdierne fra 2 lister til 1, som sorteres. Selvom der måtte være fælles værdier i de 2 lister, optræder hver værdi kun 1 gang på den færdige liste. Hvis der fx står flg. i liste 1 og 2, bliver resultatet som i 3:

1:             2:             3:
Donald Duck    Donald Duck    Batman
Spiderman      Spiderman      Berlusconi
Batman         Berlusconi     Donald Duck
                              Spiderman

Her følger kodeeksemplet.


Sub FletLister()
'Fletter to lister til én uden dubletter.
'Den flettede liste indsættes i et nyt
'regneark og sorteres.

Dim rA As Range                  'Den første liste
Dim rB As Range                  'Den anden liste
Dim rCell As Range               'Rangevariabel
Dim lCount As Long               'Tæller
Dim colMerge As New Collection   'Collection

On Error GoTo ErrorHandle

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

'Sætter de to ranges for listerne. Her har de kun
'1 kolonne hver, men der er intet i vejen for,
'at hver liste kan bestå af flere kolonner.
Worksheets(1).Activate
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(2).Activate
Set rB = Range(Range("A1"), Range("A1").End(xlDown))

'Nu tilføjes alle værdierne til vores collection.
'Dubletter undgås ved at bruge hver værdi som
'nøgle. Hvis en værdi allerede er tilføjet, udløser
'det en fejl, og derfor skriver vi nu:
On Error Resume Next

For Each rCell In rA
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rB
   colMerge.Add rCell.Value, rCell.Value
Next

On Error GoTo ErrorHandle

'Opretter en ny workbook
Workbooks.Add

'Indsætter den flettede liste med unikke værdier.
With colMerge
   For lCount = 1 To .Count
      Range("A1").Offset(lCount - 1).Value = .Item(lCount)
   Next
End With

'Listen defineres som et range
Set rA = Range(Range("A1"), Range("A1").End(xlDown))

'Og sorteres stigende (default). Hvis denne sorteringskode
'ikke virker i din Excel-version, så lav den om - evt.
'ved at bruge makrooptageren.
rA.Sort Key1:=Range("A1")

BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rCell = Nothing
Set colMerge = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure FletLister"
Resume BeforeExit
End Sub

Find fælles og ikke fælles værdier i 2 lister

Den følgende makro forudsætter ligesom den forrige, at der er en lodret liste/tabel startende i celle A1 på både faneblad 1 og 2. Makroen sammenligner de to lister og laver to nye: en med fælles værdier og en med ikke-fælles værdier. De nye lister indsættes i kolonne J og K på faneblad 1.

Til at tjekke, om en værdi fra en liste optræder på den anden, bruges regnearksfunktionen "Tæl.Hvis", som i VBA hedder "CountIf". Den tæller, hvor mange gange en given værdi optræder i et range, og en af fiduserne ved operationer som denne er at minimere antallet af gennemløb.

Du kan downloade et zip-komprimeret regneark (Excel 2003) med dette og det foregående eksempel.


Sub UnikkeOgDubletter()
'Gennemsøger to tabeller/lister og laver 2 nye
'tabeller. Den ene tabel indeholder de værdier,
'som findes i begge udgangstabeller, den anden
'de værdier, som kun er i én af udgangstabellerne.

Dim rA As Range      'Tabel 1
Dim rB As Range      'Tabel 2
Dim rCell As Range   'Rangevariabel
Dim vResult()        'Array til unikke værdier
Dim vResult2()       'Array til dubletter
Dim lCount As Long   'Tæller
Dim lCount2 As Long  'Tæller

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

'I dette eksempel går vi bare ud fra som givet,
'at der er en tabel i kolonne A. En ordentlig
'makro ville selvfølgelig tjekke dette, men jeg
'er doven i dag.
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Set rB = Worksheets(2).Range("A1")
Set rB = Range(rB, rB.End(xlDown))

'De fundne værdier vil vi skrive til 2 arrays, som
'til slut kan indsættes i regnearket i ét hug. Som
'udgangspunkt ved vi ikke, hvor mange værdier det
'drejer sig om, så vi dimensionerer disse arrays
'til at have lige så mange rækker, som de to lister
'til sammen.
ReDim vResult(1 To rA.Count + rB.Count, 1 To 1)
ReDim vResult2(1 To rA.Count + rB.Count, 1 To 1)

'Vi gennemløber nu de to ranges efter tur, og for
'hver celle tjekker vi med regnearksfunktionen
'CountIf, om værdien findes i det andet range.
'Udfaldet af dette tjek afgør, om det er en
'dublet eller ej. CountIf svarer til den danske
'regnearksfunktion "Tæl.Hvis", som returnerer
'antal forekomster i et område.
For Each rCell In rA
   With rCell
      If WorksheetFunction.CountIf(rB, .Value) = 0 Then
         lCount = lCount + 1
         vResult(lCount, 1) = .Value
      Else
         lCount2 = lCount2 + 1
         vResult2(lCount2, 1) = .Value
      End If
   End With
Next

For Each rCell In rB
   With rCell
      If WorksheetFunction.CountIf(rA, .Value) = 0 Then
         lCount = lCount + 1
         vResult(lCount, 1) = .Value
      Else
         lCount2 = lCount2 + 1
         vResult2(lCount2, 1) = .Value
      End If
   End With
Next

'Hvis der var værdier, som kun var i én
'af tabellerne:
If lCount > 0 Then
   'Vi indsætter den nye tabel i kolonne J på
   'fanebladet Table1. Det kan du ændre, som
   'du vil. Først skal vi lige definere et
   'range, som arrayet kan kopieres ind i.
   'Ranget skal have samme dimensioner som
   'arrayet:
   Set rCell = Range("J2").Resize(UBound(vResult), 1)
   rCell.Value = vResult()
   With Range("J1")
      .Value = "Unikke:"
      .Font.Bold = True
   End With
Else
   MsgBox "Alle værdier findes i begge tabeller"
End If

'Hvis der var værdier, som var i begge tabeller:
If lCount2 > 0 Then
   'Vi indsætter den nye tabel i kolonne K på
   'fanebladet Table1.
   Set rCell = Range("K2").Resize(UBound(vResult2), 1)
   rCell.Value = vResult2()
   With Range("K1")
      .Value = "Fælles:"
      .Font.Bold = True
   End With
Else
   MsgBox "Der var ingen dubletter."
End If

BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rCell = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure UnikkeOgDubletter"
End Sub

Hvis ovenstående skulle være helt guldrandet, skulle koden som nævnt tjekke, om der overhovedet er tabeller/lister fra celle A1 og ned, og den skulle også tjekke, om arrayet har flere rækker end regnearket. Hvis der fx ikke er nogen fælles værdier, er antallet af rækker jo summen af de to listers.

Kombiner 2 tabeller

Det sidste eksempel viser, hvordan man kan kombinere rækker i 2 tabeller i 2 forskellige regneark baseret på kriterium og indsætte resultatet i et nyt regneark. Her er det en tabel med kontaktpersoner og en med firmainformationer, som kombineres, hvis det samme firmanavn optræder i dem begge.

Det er lidt bøvlet at lave, hvis du selv skal lave regnearket, så jeg anbefaler, at du downloader de zip-komprimerede eksempel-regneark, hvis du vil se, hvordan eksemplet virker i praksis.

Makroerne ligger i "personer.xls" og for at virke, skal du indsætte stien til "companies.xls" på fanebladet "Macro".

Tabellen med kontaktpersoner (i "personer.xls) har flg. felter/kolonner:

Kontaktperson | Firmanavn | Telefonnummer | E-mail

Tabellen med firmaer har flg. felter/kolonner:

Firma | Adresse | Postnummer | By | Type | Info

Kort fortalt gennemløber makroen de to tabeller, og hvis der i tabellen med kontaktpersoner optræder et firmanavn, som også er i firma-tabellen, hæftes kontaktpersonens (eller personernes) oplysninger på firma-tabellens i en ny tabel, som indsættes i et nyt regneark.

Bredden (antal kolonner) i den nye tabel afhænger altså af, om der overhovedet findes kontaktpersoner med et sammenfaldende firmanavn, og i givet fald af hvor mange kontaktpersoner der er tilknyttet samme firma.

Hvis det højeste antal kontakter til et firma fx er 2, vil det give tabellen 6 kolonner mere (navn, telefonnummer og e-mail x 2).

Makroen bruger bl.a. ranges, en collection, dynamiske arrays og regnearksfunktionen "CountIf". Når jeg bruger arrays og ikke nøjes med ranges, er det for at få mere fart på. Here we go med en kopi af hele modulet:


Option Explicit
Dim bAbort As Boolean
Dim sWbName As String

'***

Sub FletLister()
'Den styrende makro

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

TjekFirmaliste	'Procedurekald
If bAbort = True Then GoTo BeforeExit
Flet	'Procedurekald

BeforeExit:
Application.ScreenUpdating = True
bAbort = False
End Sub

'***

Sub TjekFirmaliste()
'Tjekker at filen med firmalisten eksisterer
'og åbner den, hvis den ikke er åben.

Dim wb As Workbook   'Workbook-variabel
Dim sPath As String  'Strengvariabel

On Error Resume Next

'Indlæser filnavn og sti for firmalisten
With Worksheets("Macro")
   sPath = .Range("B1").Value
   If Len(sPath) > 4 Then
      sWbName = sPath
   Else
      MsgBox sPath & " er ikke et gyldigt filnavn."
      bAbort = True
      GoTo BeforeExit
   End If
   'Sti og filnavn konkateneres til én streng
   sPath = .Range("B2").Value & sWbName
   If Len(sPath) < 8 Then
      MsgBox sPath & " er ikke en gyldig sti."
      bAbort = True
      GoTo BeforeExit
   End If
End With

'Tjekker om filen er i det oplyste katalog
If Len(Dir(sPath)) = 0 Then
   MsgBox "Firmalisten er ikke i det oplyste katalog"
   bAbort = True
   GoTo BeforeExit
End If

'Åbner firmalisten, hvis den ikke
'allerede er åben.
Set wb = Workbooks(sWbName)
If wb Is Nothing Then
   Workbooks.Open (sPath)
End If

BeforeExit:
Set wb = Nothing
End Sub

'***

Sub Flet()
'Føjer kontaktpersoner til firmalisten, som
'til slut sættes ind i et nyt regneark.

Dim rPersoner As Range  'Rangevariabel til personlisten
Dim rFirmaer As Range   'Rangevariabel til firmalisten
Dim colFirmaer As New Collection 'Collection til firmanavne
Dim vContacts()         'Array til opsamling af kontakter
Dim vPersoner()         'Array med personlisten
Dim vResult()           'Resultat-arrayet
Dim lCol As Long        'Kolonnetæller
Dim lMax As Long        'Til at styre antal kolonner i sluttabellen
Dim lCount As Long      'Tæller
Dim lCount2 As Long     'Tæller
Dim lCount3 As Long     'Tæller
Dim lPcount As Long     'Tæller
Dim lLast As Long       'Kolonnetæller
Dim lHits As Long       'Tæller
Dim dFound As Double    'Tæller
Dim lResultCol As Long  'Gemmer antal kolonner i resultatarray
Dim lResultRows As Long 'Antal rækker i firmalisten

On Error GoTo ErrorHandle

ThisWorkbook.Worksheets("Persons").Activate

'Tjekker personlisten
If IsEmpty(Range("A2")) Then
   MsgBox "Første celle i personlisten er tom."
   bAbort = True
   Exit Sub
End If

'Sætter ranget med personer
If Len(Range("A3")) > 0 Then
   Set rPersoner = Range(Range("A2"), Range("A2").End(xlDown))
   Set rPersoner = Range(rPersoner, rPersoner.Offset(0, 3))
Else
   Set rPersoner = Range(Range("A2"), Range("A2").Offset(0, 3))
End If

'Person-ranget kopieres til person-arrayet.
vPersoner() = rPersoner.Value

Workbooks(sWbName).Worksheets("Companies").Activate

'Tjekker firmalisten
If IsEmpty(Range("A2")) Then
   MsgBox "Første celle i firmalisten er tom."
   bAbort = True
   Exit Sub
End If

'Sætter ranget for firmaer
If Len(Range("A3")) > 0 Then
   Set rFirmaer = Range(Range("A2"), Range("A2").End(xlDown))
   Set rFirmaer = Range(rFirmaer, rFirmaer.Offset(0, 5))
Else
   Set rFirmaer = Range(Range("A2"), Range("A2").Offset(0, 5))
End If

'Kopierer firmalisten ind i arrayet, vResult
With rFirmaer
   vResult() = .Value
   lResultCol = .Columns.Count   'Gemmer antal kolonner i variabel
   lResultRows = .Rows.Count     'Gemmer antal rækker i variabel
End With

'Sætter ranget til nothing for at spare hukommelse
Set rFirmaer = Nothing

'colFirmaer udfyldes nu med unikke firmanavne
On Error Resume Next

For lCount = 1 To UBound(vResult)
   colFirmaer.Add vResult(lCount, 1), vResult(lCount, 1)
Next

On Error GoTo ErrorHandle

'Vores collection med unikke firmanavne gennemløbes.
'For hvert firmanavn gennemløbes personlisten, og
'alle kontaktpersoner for det pågældende firma
'føjes til arrayet vContacts med 3 kolonner til
'navn, telefon og e-mail.
With colFirmaer
   'Ydre løkke som gennemløber firmanavnene
   For lCount = 1 To .Count
      'Kolonnetæller nulstilles
      lLast = 0
      'Regnearksfunktionen CountIf finder antal
      'forekomster af firmanavnet i personlisten.
      dFound = _
      WorksheetFunction.CountIf(rPersoner.Columns(2), .Item(lCount))
      If dFound > 0 Then
         lCol = dFound * 3
         'vContacts redimensioneres til antal
         'forekomster * 3 (navn, tlf. og e-mail).
         ReDim vContacts(1 To 1, 1 To lCol)
         'lMax gemmer det højeste antal kontakter * 3.
         'Bruges senere til dimensionering af
         'resultattabellen.
         If lCol > lMax Then lMax = lCol
         'Personlisten gennemløbes for at finde kontakterne
         For lPcount = 1 To UBound(vPersoner)
            'Når firmanavnet forekommer
            If vPersoner(lPcount, 2) = .Item(lCount) Then
               lHits = lHits + 1
               'Kontaktpersonens navn, telefon og e-mail gemmes
               vContacts(1, lLast + 1) = vPersoner(lPcount, 1)
               vContacts(1, lLast + 2) = vPersoner(lPcount, 3)
               vContacts(1, lLast + 3) = vPersoner(lPcount, 4)
               lLast = lHits * 3
            End If
         Next
      End If
      'Hvis firmanavnet forekom i personlisten.
      If dFound > 0 Then
         'Resultatarrayet redimensioneres om nødvendigt.
         If lResultCol < 6 + lMax Then
            lResultCol = 6 + lMax
            ReDim Preserve vResult(1 To lResultRows, 1 To lResultCol)
         End If
         'Firmalisten gennemløbes for firmanavnet
         For lCount2 = 1 To UBound(vResult)
            'Hvor firmanavnet forekommer tilføjes kontaktperson(er)
            If vResult(lCount2, 1) = .Item(lCount) Then
               'Gennemløber vContacts fra venstre mod højre og
               'indsætter kontaktinformation i resultatarrayet.
               For lCount3 = 1 To lCol
                  vResult(lCount2, 6 + lCount3) = vContacts(1, lCount3)
               Next
            End If
         Next
      End If
      lHits = 0   'lHits resettes
   Next
End With

'Tilføj nyt regneark
Workbooks.Add
'Gør det til det aktive ark
Workbooks(Workbooks.Count).Worksheets(1).Activate

'På faneblad 1 defineres et range med
'samme dimensioner som resultatarrayet.
Set rPersoner = Range(Range("A2"), Range("A2").Offset(lResultCol))
Set rPersoner = rPersoner.Resize(lResultRows, lResultCol)
'Tabellen, vResult, indsættes i ét hug.
rPersoner.Value = vResult()

'I det følgende formateres tabellen.
'Første række:
Set rFirmaer = _
Range(Range("A1"), Range("A1").Offset(0, lResultCol - 1))
With rFirmaer
   .Interior.Color = 12688476
   .Font.Bold = True
   .Font.ColorIndex = 2
   .Item(1).Value = "Kunde navn"
   .Item(2).Value = "Adresse 1"
   .Item(3).Value = "Postnummer"
   .Item(4).Value = "By"
   .Item(5).Value = "Type"
   .Item(6).Value = "Info"
   For lCount = 7 To lResultCol
      lHits = lCount Mod 3
      Select Case lHits
         Case 1
            .Item(lCount).Value = "Kontaktpersoner"
         Case 2
            .Item(lCount).Value = "Telefonnummer"
         Case 0
            .Item(lCount).Value = "E-mail"
      End Select
   Next
End With

'Nu farves hver 2. række i tabellen grå
With rPersoner
   For lCount = 1 To lResultRows Step 2
      If lCount > lResultRows Then Exit For
      .Rows(lCount).Interior.Color = 15000804
   Next
End With

Set rFirmaer = rFirmaer.Resize(lResultRows + 1)
With rFirmaer
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
    .Columns.AutoFit
End With
   
BeforeExit:
Set rPersoner = Nothing
Set rFirmaer = Nothing
Set colFirmaer = Nothing
Erase vResult
Erase vPersoner
Erase vContacts
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Flet"
bAbort = True
End Sub

Det var det. Som sagt vil jeg anbefale, at du downloader regnearkene, hvis du vil se makroerne i aktion. Med makroer i VBA kan man automatisere, næsten hvad det skal være i Excel - også fletning eller kombination af data.

God fornøjelse!

Relateret: