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
Excel VBA - Porovnani dat dvou dvojic sloupcu Vyřešeno
Excel VBA - Porovnani dat dvou dvojic sloupcu Vyřešeno
- Přílohy
-
- Sešit1.xls
- (27 KiB) Staženo 71 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Zanalyzuj si nasledujici proceduru:
Predpoklad pro spravny vysledek je, ze dvojice hodnot z list1!Axx:Bxx a list2!Ayy:Byy jsou unikatni.
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.
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
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).
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).
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Upravena procedura, v list2!Axx:Bxx jsou dvojice hodnot unikatni:
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
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
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
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.
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
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Mas to upraveno spravne, ja jsem vice mene jen ve zjednodusene procedure doplnil porovnani absolutnich hodnot.
Re: Excel VBA - Porovnani dat dvou dvojic sloupcu
Ok, jeste jednou diky za pomoc.
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 9
- 2962
-
od MK_Vs
Zobrazit poslední příspěvek
02 lis 2023 09:26
-
- 6
- 2048
-
od Faster1
Zobrazit poslední příspěvek
08 zář 2023 16:27
-
- 0
- 2356
-
od luko02420
Zobrazit poslední příspěvek
02 srp 2023 14:12
-
- 4
- 780
-
od petr22
Zobrazit poslední příspěvek
11 čer 2023 13:51
-
- 12
- 3034
-
od amirinda
Zobrazit poslední příspěvek
14 říj 2023 16:39
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 13 hostů