20. maj 2008 - 11:52Der er
19 kommentarer og 1 løsning
Sammenligne indhold i to faner
Hej
Jeg har et problem jeg skal have knækket, så jeg håber på hjælp her.
Jeg har en liste over nogle systembrugere til to forskellige systemer på min arbejdsplads. Excellarket består af 2 faner. En til system "A" og en til system "B". Begge systemer varetager nogenlunde samme opgaver og nu skal system "B" udfases, således at alle brugerne skal have kompetencer i system "A". Det giver os nogle udfordringer i forbindelse med planlægning af uddannelse osv, så jeg har brug for en sortering.
Vi har 3 typer brugere:
1. Brugere med kompetencer i system "A" 2. Brugere med kompetencer i system "B" 3. Brugere med kompetencer i system "A" og "B".
Pt. kan jeg identificere alle brugere med kompetencer enten i system "A" eller i system "B", men eftersom vi har brugere med kompetencer i begge, er disses behov for uddannelse ikke så stort.
- Jeg forestiller mig at det er muligt at sammenligne de to faner og evt. flytte alle de brugere der har kompetencer i begge systemer over til fane 3 (at de optræder 2 gange her gør intet - jeg kan jo blot dividere med 2).
Brugerne har samme brugerid i begge systemer, baseret på deres personalenummer, som fremgår i en kolonne på hver fane.
Det kan tænkes at løsningen er simpel, men jeg er ikke for hot til excell, så hjælp vil være kærkomment.
Rem Arkene forventes at ligge som Ark1 (A), Ark2 (B) & Ark3 (A+B) Rem KODEN INDSÆTTES I ARK1 (Højklik på arkfanen - Vis Programkode) Rem Koden startes Fra Ark1 - Alt+F8 - Afspil makroen SammenLigning Rem Const-værdierne kan evt. ændres Rem ============================================================== Const startRæk = 2 'Hvis overskrift Const nrKol = "A" 'Kolonne for medarb.Nr
Dim arkB, arkAB Sub sammenligNing() Dim medarbnr, abRæk, bræk abRæk = startRæk
Rem definer Ark B & Ark AB Set arkB = ActiveWorkbook.Sheets(2) Set arkAB = ActiveWorkbook.Sheets(3)
Application.ScreenUpdating = False
Rem GennemGå ark A For ræk = startRæk To 65000 medarbnr = Cells(ræk, nrKol)
Rem Fortsæt indsæt tom celle i Kol A mødes If medarbnr = "" Then Exit For End If
Rem udfør opslag om medarbnr findes i Ark B bræk = findesMedArbNr(medarbnr) If bræk > 0 Then opdaterArkAB medarbnr, bræk, abRæk End If Next ræk
Application.ScreenUpdating = True
Worksheets(3).Activate MsgBox ("Sammenligning er afsluttet") End Sub Private Function findesMedArbNr(medarbnr) 'findes Nr i ark B With arkB.Range(nrKol + CStr(startRæk) & ":" + nrKol + "65000") Set c = .Find(medarbnr, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then findesMedArbNr = c.Row Exit Function Else findesMedArbNr = 0 End If End With End Function Private Sub opdaterArkAB(medarbnr, bræk, abRæk) arkB.Activate ActiveSheet.Rows(bræk).Select Selection.Copy
Den tager dem fra Ark2, som også finde i Ark1 og putter over i Ark3. Kan du også gøre således at den sletter de entries den tager fra ark1 og ark2, således at man får følgende resultat:
Ark1: brugere med udelukkende system A kompetencer Ark2: brugere med udelukkende system B kompetencer Ark3: brugere med kompetencer i begge systemer.
Rem ========= Rem Version 2 Rem ========= Rem Arkene forventes at ligge som Ark1 (A), Ark2 (B) & Ark3 (A+B) Rem KODEN INDSÆTTES I ARK1 (Højklik på arkfanen - Vis Programkode) Rem Koden startes Fra Ark1 - Alt+F8 - Afspil makroen SammenLigning Rem Const-værdierne kan evt. ændres Rem ============================================================== Const startRæk = 2 'Hvis overskrift Const nrKol = "A" 'Kolonne for medarb.Nr
Dim arkB, arkAB Sub sammenligNing() Dim medarbnr, abRæk, bræk abRæk = startRæk
Rem definer Ark B & Ark AB Set arkB = ActiveWorkbook.Sheets(2) Set arkAB = ActiveWorkbook.Sheets(3)
Application.ScreenUpdating = False
Rem GennemGå ark A For ræk = startRæk To 65000 medarbnr = Cells(ræk, nrKol)
Rem Fortsæt indsæt tom celle i Kol A mødes If medarbnr = "" Then Exit For End If
Rem udfør opslag om medarbnr findes i Ark B bræk = findesMedArbNr(medarbnr) If bræk > 0 Then opdaterArkAB medarbnr, bræk, abRæk
Rem indsæt markering for slettes Cells(ræk, 1) = "X" End If Next ræk
SletA_B
Application.ScreenUpdating = True
Worksheets(3).Activate MsgBox ("Sammenligning er afsluttet") End Sub Private Function findesMedArbNr(medarbnr) 'findes Nr i ark B With arkB.Range(nrKol + CStr(startRæk) & ":" + nrKol + "65000") Set c = .Find(medarbnr, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then findesMedArbNr = c.Row Exit Function Else findesMedArbNr = 0 End If End With End Function Private Sub opdaterArkAB(medarbnr, bræk, abRæk) arkB.Activate ActiveSheet.Rows(bræk).Select Selection.Copy
Rem indsæt markering for slettes arkB.Activate arkB.Cells(bræk, 1) = "X"
Application.CutCopyMode = False
abRæk = abRæk + 1 End Sub Private Sub SletA_B() udførSletning 1 udførSletning 2 End Sub Private Sub udførSletning(ArkNr) Dim ark Set ark = ActiveWorkbook.Sheets(ArkNr) ark.Activate For ræk = startRæk To 65000 If ActiveSheet.Cells(ræk, 1) = "" Then Exit Sub End If
If ActiveSheet.Cells(ræk, 1) = "X" Then ActiveSheet.Rows(ræk).Select Selection.Delete Shift:=xlUp ræk = ræk - 1 End If Next ræk End Sub
Så fik jeg endelig testet det - Jeg har overdrevent travlt med alverdens ting og sager, så det kunne først blive nu. Og det fungerer selvfølgelig perfekt. Jeg har krydsberegnet med det oprindelige dokument og kan se at summen er korrekt.
Det er alt for fedt. Jeg ville ønske at jeg havde sat flere point på højkant - jeg troede at det nærmest var lidt menuvalg, men at der ligefrem skulle programmering til - og at det kom så hurtigt og smertefrit er helt vildt fedt.
Jeg har forhøjet til 150 point pga. din skræddersyede løsning. Nu skal jeg bare finde ud af at distribuere pointene til dig. Jeg forventede en knap med teksten "distribuer point". Nå, jeg tjekker det lige efter frokostpausen.
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
