Két tartomány összehasonlításáról már született poszt:
Ennél a két tartomány adatainak összevetése celláról cellára történt és a különbségek színezés által kerültek kiemelésre.
A mai bejegyzésében azonban a két tartomány minden adatát vetjük össze, cellapozíciótól függetlenül és az egyedi illetve közös adatokat is kilistázzuk egy munkalapon. Valahogy így:
Látható, hogy a zöld hátterű cellák mindkét tartományban közösek, így ezek adatai a “D” oszlopban kerülnek kiíratásra, míg az első és második tartomány egyedi adatai az “E” és “F” oszlopokban.
A kijelölt tartomány állhat nem összefüggő cellákból is, ezt a CTRL billentyű lenyomásával érhetjük el kijelölés közben. Vagy akár kijelölhetünk és összehasonlíthatunk teljes sorokat/oszlopokat is.
Az adott munkafüzetben nyissuk meg a Visual Basic szerkesztőjét (ALT + F11-gyel). Majd szúrjunk be egy modult és az alábbi kódot adjuk hozzá. Ezen felül az egyéni makró munkafüzetbe (Personal.xlsb-hez) is beszúrhatunk egy modult és ahhoz is hozzáadhatjuk a makrót, ha más munkafüzetekből is futtatni akarjuk. A kódban megjegyzésként hozzáadtam a megértést segítő magyarázatokat:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
Sub KetTartomanyOsszehasonlitasa02() Dim Tart1 As Range, Tart2 As Range, CelCella As Range, Cella Dim D As Object, D2 As Object, D3 As Object, D4 As Object, D5 As Object, X, Y, Z, i As Long, j As Long, Van As Boolean Dim Fejlec() Fejlec = Array("Közös", "Elsõ tartomány", "Második Tartomány") 'Készítette: XLMotyo (https://xlmotyo.hu) 'ez a kód a felhasználó által kijelölt egyik tartomány összes celláját veti össze a másik tartomány összes cellájával és 'az egyedi illetve közös adatokat is kilistázza a munkalapon 'a kijelölt tartomány állhat nem összefüggõ cellákból is:a CTRL billentyûvel lenyomásával jelölhetünk ki különbözõ cellákat Set D = CreateObject("scripting.dictionary") Set D2 = CreateObject("scripting.dictionary") Set D3 = CreateObject("scripting.dictionary") Set D4 = CreateObject("scripting.dictionary") Set D5 = CreateObject("scripting.dictionary") 'felhasználó jelölje ki a két tartományt és azt a cellát, ahol a kiíratás kezdõdni fog On Error GoTo Vege Set Tart1 = Application.InputBox("Jelöld ki az elsõ tartományt", "Elsõ tartomány", , , , , , 8) Set Tart2 = Application.InputBox("Jelöld ki a második tartományt!", "Második tartomány", , , , , , 8) Set CelCella = Application.InputBox("A kiíratás kezdõ (bal felsõ) celláját jelöld ki!", "Kiíratás elsõ cella", , , , , , 8) If CelCella.Count <> 1 Then MsgBox "A kiíratás kezdõ (bal felsõ) celláját jelöld ki!", , "EGY cella kijelöése" Exit Sub End If On Error GoTo 0 '----------------------------- 'Elsõ tartomány összes adatának eltárolása: For Each Cella In Tart1.Cells If Cella <> "" Then D(CStr(Cella.Value)) = "" Next Cella 'Második tartomány összes adatának eltárolása: For Each Cella In Tart2.Cells If Cella <> "" Then D2(CStr(Cella.Value)) = "" Next Cella X = D.keys Y = D2.keys 'Két tartomány közös adatainak eltárolása For i = 0 To D.Count - 1 For j = 0 To D2.Count - 1 If X(i) = Y(j) Then D3(X(i)) = "" Exit For End If Next j Next i Z = D3.keys 'Elsõ tartomány egyedi adatainak eltárolása For i = 0 To D.Count - 1 'Elsõ tartomány Van = False For j = 0 To D3.Count - 1 'Két tartomány közös adatai If X(i) = Z(j) Then Van = True Exit For End If Next j If Not Van Then D4(X(i)) = "" 'egyedi adatok Next i 'Második tartomány egyedi adatainak eltárolása For i = 0 To D2.Count - 1 'Második tartomány Van = False For j = 0 To D3.Count - 1 ''Két tartomány közös adatai If Y(i) = Z(j) Then Van = True Exit For End If Next j If Not Van Then D5(Y(i)) = "" 'egyedi adatok Next i '-------------------------------------------------------- 'Kiíratás fejlécének megadása, majd formázása: CelCella.Cells(1, 1).Resize(, UBound(Fejlec) + 1) = Fejlec Range(CelCella.Address, CelCella.Offset(0, 2).Address).Font.Bold = True '------------------------------------------------------------------------ 'a munkalapon történõ horizontális kiíratás (tartományok egyedi és közös adatai) 'ActiveWorkbook.ActiveSheet.Range and .Address: azért kell, mert így 'a kód az egyéni makró munkafüzetben (Personal.xlsb-ben) is mûködik If D3.Count <> 0 Then ActiveWorkbook.ActiveSheet.Range(CelCella.Address).Offset(1, 0).Resize((UBound(D3.keys) + 1), 1) = _ Application.Transpose(D3.keys) 'Két tartomány közös adatai If D4.Count <> 0 Then ActiveWorkbook.ActiveSheet.Range(CelCella.Address).Offset(1, 1).Resize((UBound(D4.keys) + 1), 1) = _ Application.Transpose(D4.keys) 'Elsõ tartomány adatai If D5.Count <> 0 Then ActiveWorkbook.ActiveSheet.Range(CelCella.Address).Offset(1, 2).Resize((UBound(D5.keys) + 1), 1) = _ Application.Transpose(D5.keys) 'Második tartomány adatai '---------------------------------------------------------- 'Kiíratási tartomány formázása: With CelCella.Offset(0, 1).CurrentRegion .Columns.AutoFit .HorizontalAlignment = xlCenter End With Vege: End Sub |
