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()
Dim rA As Range
Dim rB As Range
Dim rCell As Range
Dim lCount As Long
Dim colMerge As New Collection
On Error GoTo ErrorHandle
Application.ScreenUpdating = False
Worksheets(1).Activate
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(2).Activate
Set rB = Range(Range("A1"), Range("A1").End(xlDown))
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
Workbooks.Add
With colMerge
For lCount = 1 To .Count
Range("A1").Offset(lCount - 1).Value = .Item(lCount)
Next
End With
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
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()
Dim rA As Range
Dim rB As Range
Dim rCell As Range
Dim vResult()
Dim vResult2()
Dim lCount As Long
Dim lCount2 As Long
On Error GoTo ErrorHandle
Application.ScreenUpdating = False
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Set rB = Worksheets(2).Range("A1")
Set rB = Range(rB, rB.End(xlDown))
ReDim vResult(1 To rA.Count + rB.Count, 1 To 1)
ReDim vResult2(1 To rA.Count + rB.Count, 1 To 1)
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
If lCount > 0 Then
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
If lCount2 > 0 Then
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()
Application.ScreenUpdating = False
TjekFirmaliste
If bAbort = True Then GoTo BeforeExit
Flet
BeforeExit:
Application.ScreenUpdating = True
bAbort = False
End Sub
Sub TjekFirmaliste()
Dim wb As Workbook
Dim sPath As String
On Error Resume Next
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
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
If Len(Dir(sPath)) = 0 Then
MsgBox "Firmalisten er ikke i det oplyste katalog"
bAbort = True
GoTo BeforeExit
End If
Set wb = Workbooks(sWbName)
If wb Is Nothing Then
Workbooks.Open (sPath)
End If
BeforeExit:
Set wb = Nothing
End Sub
Sub Flet()
Dim rPersoner As Range
Dim rFirmaer As Range
Dim colFirmaer As New Collection
Dim vContacts()
Dim vPersoner()
Dim vResult()
Dim lCol As Long
Dim lMax As Long
Dim lCount As Long
Dim lCount2 As Long
Dim lCount3 As Long
Dim lPcount As Long
Dim lLast As Long
Dim lHits As Long
Dim dFound As Double
Dim lResultCol As Long
Dim lResultRows As Long
On Error GoTo ErrorHandle
ThisWorkbook.Worksheets("Persons").Activate
If IsEmpty(Range("A2")) Then
MsgBox "Første celle i personlisten er tom."
bAbort = True
Exit Sub
End If
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
vPersoner() = rPersoner.Value
Workbooks(sWbName).Worksheets("Companies").Activate
If IsEmpty(Range("A2")) Then
MsgBox "Første celle i firmalisten er tom."
bAbort = True
Exit Sub
End If
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
With rFirmaer
vResult() = .Value
lResultCol = .Columns.Count
lResultRows = .Rows.Count
End With
Set rFirmaer = Nothing
On Error Resume Next
For lCount = 1 To UBound(vResult)
colFirmaer.Add vResult(lCount, 1), vResult(lCount, 1)
Next
On Error GoTo ErrorHandle
With colFirmaer
For lCount = 1 To .Count
lLast = 0
dFound = _
WorksheetFunction.CountIf(rPersoner.Columns(2), .Item(lCount))
If dFound > 0 Then
lCol = dFound * 3
ReDim vContacts(1 To 1, 1 To lCol)
If lCol > lMax Then lMax = lCol
For lPcount = 1 To UBound(vPersoner)
If vPersoner(lPcount, 2) = .Item(lCount) Then
lHits = lHits + 1
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
If dFound > 0 Then
If lResultCol < 6 + lMax Then
lResultCol = 6 + lMax
ReDim Preserve vResult(1 To lResultRows, 1 To lResultCol)
End If
For lCount2 = 1 To UBound(vResult)
If vResult(lCount2, 1) = .Item(lCount) Then
For lCount3 = 1 To lCol
vResult(lCount2, 6 + lCount3) = vContacts(1, lCount3)
Next
End If
Next
End If
lHits = 0
Next
End With
Workbooks.Add
Workbooks(Workbooks.Count).Worksheets(1).Activate
Set rPersoner = Range(Range("A2"), Range("A2").Offset(lResultCol))
Set rPersoner = rPersoner.Resize(lResultRows, lResultCol)
rPersoner.Value = vResult()
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
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:
|