Stránka 1 z 1
Excel VBA - Porovnani dat dvou dvojic sloupcu Vyřešeno
Napsal: 09 úno 2011 13:51
od 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
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Napsal: 09 úno 2011 14:57
od 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 SubPredpoklad pro spravny vysledek je, ze dvojice hodnot z list1!Axx:Bxx a list2!Ayy:Byy jsou unikatni.
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Napsal: 09 úno 2011 15:50
od 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).
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Napsal: 09 úno 2011 17:50
od 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 SubPokud 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
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Napsal: 10 úno 2011 10:31
od 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
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Napsal: 10 úno 2011 11:58
od navstevnik
Mas to upraveno spravne, ja jsem vice mene jen ve zjednodusene procedure doplnil porovnani absolutnich hodnot.
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Napsal: 10 úno 2011 12:06
od Adalbert
Ok, jeste jednou diky za pomoc.