Excel VBA - Porovnani dat dvou dvojic sloupcu

[Adalbert]

Zdravim,

Potrebuji vyresit nasledujici ulohu:

DATA:
List1 - 3 sloupce (A,B,C)
List2 - 2 sloupce (A,B)

ULOHA:
porovnat data dvojic sloupu A, B v obou listech a pri shode doplnit do List2 odpovidajici hodnotu ze sloupce C (taktez do sloupce C)
Tzn. musi odpovidat A i B aby doslo k doplneni hodnoty.

Bohuzel jsem skoncil na tomto:
Problem mam s definovanim prave kontroly obou sloupcu, prestoze zadavam A:B, evidentne mi bere a porovnava pouze jednu hodnotu a to prvni, tedy ze sloupce A.

Option Explicit

Sub DoplnHodnoty()
Dim SWsht As Worksheet, SBlk As Range, SCll As Range
Dim TWsht As Worksheet, TBlk As Range, TCll As Range

Set SWsht = Worksheets("list1")
With SWsht
Set SBlk = Intersect(.UsedRange, .Range("a:b"))
End With

Set TWsht = Worksheets("list2")
With TWsht
Set TBlk = Intersect(.UsedRange, .Range("a:b"))
End With

For Each TCll In TBlk.Cells
With SBlk
Set SCll = .Find(TCll.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SCll Is Nothing Then
TCll.Offset(0, 2).Value = SCll.Offset(0, 2).Value
End If
End With
Next TCll

Set SCll = Nothing
Set SBlk = Nothing
Set SWsht = Nothing
Set TCll = Nothing
Set TBlk = Nothing
Set TWsht = Nothing
End Sub

[navstevnik]

Zanalyzuj si nasledujici proceduru:

Kód: Vybrat vše

Option Explicit

Sub VyhledatDoplnit()
  Dim BlkA As Range, BlkB As Range
  Dim CllA As Range, CllB As Range
  Dim frstAddr As String
  ' definovani bloku bunek na listech
  With Worksheets("list1")
    Set BlkA = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  With Worksheets("list2")
    Set BlkB = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  ' prochazet BlkA
  For Each CllA In BlkA.Cells
    ' prohledavat BlkB
    With BlkB
      Set CllB = .Find(CllA.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
      If Not CllB Is Nothing Then  ' pri shode porovnat sloupce B:B
        frstAddr = CllB.Address
        Do
          If CllB.Offset(0, 1).Value = CllA.Offset(0, 1).Value Then  ' pri shode doplnit do sl C:C data
            CllB.Offset(0, 2).Value = CllA.Offset(0, 2).Value
          End If
          Set CllB = .FindNext(CllB)
        Loop While CllB.Address <> frstAddr
      End If
    End With
  Next CllA
  ' odstranit objektove promenne
  Set CllB = Nothing
  Set CllA = Nothing
  Set BlkB = Nothing
  Set BlkA = Nothing
End Sub

Predpoklad pro spravny vysledek je, ze dvojice hodnot z list1!Axx:Bxx a list2!Ayy:Byy jsou unikatni.

[Adalbert]

Diky. Pri zachovani unikatnosti hodnot z list1!Axx:Bxx a list2!Ayy:Byy plni procedura me ocekavani.
Bohuzel zachovani unikatnosti pro list1!Axx:Bxx nemam garantovano (existuje moznost ze v budoucnu unikatnost nebude).
Jelikoz vsak hodnoty ktere takto prevadim z list1!C1:C do list2!C1:C jsou striktne cela cisla (v rozsahu -100 az 100) chtel bych toto resit dalsi podminkou; neco ve smyslu: Pokud neni pole (do ktereho se ma prenaset hodnota) prazne, porovnej absolutni hodnoty cisla prenaseneho a cisla jiz existujicicho a zapis nove prenasene cislo pouze v pripade, je li jeho absolutni hodnota vetsi nez absolutni hodnota cisla jiz existujiciho. S osetrenim vyjimky rovnosti cisel (vyhodilo by chybu napr "kolize cisel"). S tim ze pri prenosu by se prenasela cisla v podobe jak byla zaznamenana v list1!C1:C a nikoliv v absolutni podobe (absolutni hodnota by slouzila pouze pro porovnani cisel).

[navstevnik]

Upravena procedura, v list2!Axx:Bxx jsou dvojice hodnot unikatni:

Kód: Vybrat vše

Option Explicit

Sub VyhledatDoplnit()
  Dim BlkA As Range, BlkB As Range
  Dim CllA As Range, CllB As Range
  ' definovani bloku bunek na listech
  With Worksheets("list1")
    Set BlkA = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  With Worksheets("list2")
    Set BlkB = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  ' prochazet BlkA
  For Each CllA In BlkA.Cells
    ' prohledavat BlkB
    With BlkB
      Set CllB = .Find(CllA.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
      If Not CllB Is Nothing Then  ' pri shode porovnat sloupce B:B
        If CllB.Offset(0, 1).Value = CllA.Offset(0, 1).Value Then  ' pri shode doplnit do sl C:C data
          ' abs nova hodnota > abs stara hodnota
          If Abs(CllA.Offset(0, 2).Value) >= Abs(CllB.Offset(0, 2).Value) Then
            CllB.Offset(0, 2).Value = CllA.Offset(0, 2).Value
          End If
        End If
      End If
    End With
  Next CllA
  ' odstranit objektove promenne
  Set CllB = Nothing
  Set CllA = Nothing
  Set BlkB = Nothing
  Set BlkA = Nothing
End Sub

Pokud bude zadouci starou hodnotu nahradit novou pri shode absolutnich hodnot (30 nahradit -30) uprav podminku na:
If Abs(CllA.Offset(0, 2).Value) >= Abs(CllB.Offset(0, 2).Value) Then

[Adalbert]

Diky hodne jsi mi pomohl.
Pro kontrolu jen prikladam jeste mnou upravenou proceduru. Resp, pridal jsem jeste cast kodu z prvni tve procedury, ktery tam tobe ted vypadl a bez nejz mi tva druha procedura nepracovala spravne. Doufam, ze takto je kod cisty a spravny. S VBA pracuji teprve par dnu.

Kód: Vybrat vše

    
Option Explicit

    Sub VyhledatDoplnit()
      Dim BlkA As Range, BlkB As Range
      Dim CllA As Range, CllB As Range
      Dim frstAddr As String
      ' definovani bloku bunek na listech
      With Worksheets("list1")
        Set BlkA = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
      End With
      With Worksheets("list2")
        Set BlkB = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
      End With
      ' prochazet BlkA
      For Each CllA In BlkA.Cells
        ' prohledavat BlkB
        With BlkB
          Set CllB = .Find(CllA.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
          If Not CllB Is Nothing Then  ' pri shode porovnat sloupce B:B
            frstAddr = CllB.Address
            Do
              If CllB.Offset(0, 1).Value = CllA.Offset(0, 1).Value Then  ' pri shode doplnit do sl C:C data
                ' abs nova hodnota > abs stara hodnota
                 If Abs(CllA.Offset(0, 2).Value) > Abs(CllB.Offset(0, 2).Value) Then
                 CllB.Offset(0, 2).Value = CllA.Offset(0, 2).Value
                 End If
              End If
             Set CllB = .FindNext(CllB)
             Loop While CllB.Address <> frstAddr
           End If
        End With
      Next CllA
      ' odstranit objektove promenne
      Set CllB = Nothing
      Set CllA = Nothing
      Set BlkB = Nothing
      Set BlkA = Nothing
    End Sub

[navstevnik]

Mas to upraveno spravne, ja jsem vice mene jen ve zjednodusene procedure doplnil porovnani absolutnich hodnot.

[Adalbert]

Ok, jeste jednou diky za pomoc.