Porovnání 2 listů - Excel

Zdravím, mám za úkol vymyslet makro na porovnání 2 listů. Jde o vyexportované tabulky ze SAPu ze dvou po sobě jdoucích dnů na odvolávky zákazníka. Makro by mělo porovnat týden a v novější tabulce (Sheet2) zvýraznit červeně buňky, které jsou rozdílné od první tabulky (Sheet1).

Zatím mám jen naprogramované načtení oblasti buněk pro porovnání, ale nevím, jak napsat kód pro porovnání těchto oblastí (For each bunka in oblast1...). Zde je odkaz na testovací tabulku a pod ní kód, který zatím mám. Díky moc!

http://previt.wz.cz/ostatni/test.xls

Citace:

---

Sub Porovnej() 'porovná 2 listy a pokud najde rozdíl označí ho

Application.ScreenUpdating = False
Dim text As String
Dim oblast1 As Range, oblast2 As Range, bunka As Range
Dim radky As Integer


'spočítá počet buněk, které se budou testovat
Sheets("Sheet1").Activate
ActiveSheet.Range("B2").Select
radky = 2
text = ActiveCell.Formula
Do Until text = ""
ActiveCell.Offset(1, 0).Select
text = ActiveCell.Formula
radky = radky + 1
Loop
oblast1 = "D2:D" & radky - 1 & ",F2:K" & radky - 1
oblast2 = "D2:D" & radky - 1 & ",E2:J" & radky - 1

---

A počet a pořadí řádků tabulky bude vždy stejné, nebo se může taky lišit? A pokud třeba v novém listu přibude řádek, kde bude ve sloupci "Material" hodnota 11, která na "starém" listu nebyla? Má to tedy na "novém" vyznačit celý řádek pro Material = 11 červeně?

Jinak v základu bych na to algoritmem šel úplně jednoduše:

a) Zjistit si "průnik množin datumů" ve "staré" a "nové" tabulce - jednoduše tak, že vezmu první sloupec s datumem v nové tabulce, vyhledám sloupec, který bude mít stejné datum ve staré tabulce, pak spočítám počet "platných" sloupců až do konce "staré" tabulky, vyjde mi dejme tomu, že

ve "staré" budu porovnávat sloupce 10,11,12,13
v "nové" budu porovnávat sloupce 6,7,8,9

Pak bych už jel uplně jednoduše, bral bych řádek po řádku hodnoty sloupce "Material" v nové tabulce, hledal řádek s odpovídající hodnotou v té staré, projel pak daný řádek přes srovnávané sloupce a odpovídající buňky obarvil.

Určitě by se to pak ještě dalo nějak optimalizovat, v případě splnění některých (tabulka bude seřazena vzestupně dle sloupce Material atd.) podmínek atd., ale v kostce by to takhle v základu fungovat mohlo.

Psát to "VBAčkovsky" bohužel teď v práci nemám čas, snad večer, pokud to už někdo nenapíše za mě ;-)

Tabulka bude vypadat stále víceméně stejně - staré datumy budou vypadávat, takže Sheet1 bude vždy o 1 den starší a budou se porovnávat až následující dny. Nový materiál bych určitě neřešil (tato možnost se nestane a když ano, tak to bude záležitost jen 2 dnů než algoritmus automaticky začlení i tento materiál do srovnání).

ad a) množiny jsou již nastavené v kódu co mám (oblast1 - Sheet1, oblast2 - Sheet2) - je to vidět že oblast 2 je posunutá o jeden sloupec. Materiál je vždy seřazen vzestupně, takže hledání odpadá a stačí projíždět řádek po řádku.

Spíš bych potřeboval pomoct s kódem jako takovým, jako udělat něco ve stylu:

For each bunka in oblast1 do
text = activecell.formula
porovnej přislušnou bunku v oblast2 s text

Možná jsem četl špatně, ale dá se zjednodušeně říct, že např. buňka G2 v listu Sheet2 se bude vždycky porovnávat s buňkou F2 v listu Sheet1 ?
Jestli ano, tak bych to asi neřešil makrem, ale jenom třeba podmíněným formátováním buněk. Když Sheet2!G2 <> Sheet1!F2 ... formát buňky takový makový.

Citace:

---

Původně odeslal malli

Možná jsem četl špatně, ale dá se zjednodušeně říct, že např. buňka G2 v listu Sheet2 se bude vždycky porovnávat s buňkou F2 v listu Sheet1 ?
Jestli ano, tak bych to asi neřešil makrem, ale jenom třeba podmíněným formátováním buněk. Když Sheet2!G2 <> Sheet1!F2 ... formát buňky takový makový.

---

No, to už jsem taky zkoušel, ale Excel mi tvrdí, že u podmíněného formátování nelze použít odkaz na jiný list/sešit..

Zkoušel jsem to v tom tvém vzorovém listu a fungovalo to bez problémů. Nicméně ve verzi 2010. Jak se k tomu staví nižší verze nevím, teď k nim nemám přístup.
EDIT: A i kdyby to nešlo, pak by se teoreticky daly ve třetím (jiném) listu sloučit ty dva dohromady jednoduchými odkazy a pak už můžeš používat podmíněné formátování v jednom listu. Ale nevím, jestli už moc neznásilňuju zadání :-)

Právě že máme Office 2003 a tam to nejde.. :( Já bych chtěl právě něco jednoduchého, protože to potom dál už nebudu dělat já, ale jiní. A ti dokáží tak akorát vyexportovat tabulku ze SAPu, dát ty 2 listy do jednoho souboru a spustit něco, co jim to všechno označí. S tou možností třetího listu by bylo asi zbytečně moc složité..

No ono by to zase tak složitý na používání nebylo. Prostě by spustili sešit, kde by na Listu 3 bylo ono vyhodnocení. Jejich úkol by byl jenom ze SAPu nakopírovat export do listu 1 a 2, poté by se přepnuli do listu 3 a tam by viděli výsledky.
Někde na souřadnicích FF1000, tak aby to bylo daleko od běžného použití a navíc skryté, by se jen zajistily kopie těch dvou listů a na souřadnicích A1 apod by se zobrazil požadovaný výsledek, čili porovnávání by probíhalo jen na listu 3.

Ať nezakládám nové vlákno tak to píšu sem. Řeším další problém a to, že jsou 3 stejné tabulky (jen obsahují jiná data) a pak jedna tabulka generovaná pomocí VBA (takový souhrn všech tří). VBA vždy zjistí počet řádku ve všech tabulkách a podle toho vytvoří řádky v souhrnu a nakopíruje tam data ze všech 3 tabulek.

Problém je, že lidé používají filtry a já nevím jak udělat, aby VBA počítalo i skryté řádky. Navíc mám problém s kopírováním, jednu tabulku to zkopíruje ale další už ne..

Citace:

---

Sub Nakopiruj()
Application.ScreenUpdating = False 'zakázat vykreslování v průběhu makra - zvýší rychlost
Dim bunka As String, oblast_overall As String, oblast As String, list As String
Dim i, radky_overall, radky_jp, radky_jk, radky_celkem As Integer
radky_overall = 4
radky_jp = 0
radky_jk = 0

Sheets("JK targets").Activate ' zjistí počet řádků k první prázdné buňce v JK
ActiveSheet.Range("A4").Select
bunka = ActiveCell.Formula
Do Until bunka = ""
ActiveCell.Offset(1, 0).Select
bunka = ActiveCell.Formula
radky_jk = radky_jk + 1
Loop

Sheets("JP targets").Activate ' zjistí počet řádků k první prázdné buňce v JP
ActiveSheet.Range("A4").Select
bunka = ActiveCell.Formula
Do Until bunka = ""
ActiveCell.Offset(1, 0).Select
bunka = ActiveCell.Formula
radky_jp = radky_jp + 1
Loop

radky_celkem = radky_jk + radky_jp

Sheets("customers sumarry").Activate ' zjistí počet řádků k "notes" v overall
ActiveSheet.Range("B4").Select
bunka = ActiveCell.Formula
Do Until bunka = "notes"
ActiveCell.Offset(1, 0).Select
bunka = ActiveCell.Formula
radky_overall = radky_overall + 1
Loop

ActiveSheet.Range("A5").Select ' vymaže řádky od začátku k "notes"
If radky_overall > 9 Then
For i = 5 To radky_overall - 3
Selection.EntireRow.Delete
Next i
End If

For i = 4 To radky_celkem 'vloží řádky
Cells(i + 1, 1).EntireRow.Insert
Next

'oblast = "A4:AG" & radky_jp - 1 ' oblast, která se bude kopírovat
'oblast_overall = "A4:AG" & radky_jp - 1 'oblast kam se bude kopírovat
'list = "JP targets"
'Kopie oblast_overall, oblast, list

oblast = "A4:AG" & radky_jk - 1 ' oblast, která se bude kopírovat
oblast_overall = "A" & radky_jp & ":AG" & radky_jk - 1 'oblast kam se bude kopírovat
list = "JK targets"
Kopie oblast_overall, oblast, list


Application.ScreenUpdating = True 'povolit vykreslování
End Sub
Sub Kopie(oblast_overall As String, oblast As String, list As String) 'nakopiruje zadany list do overall
Application.ScreenUpdating = False 'zakázat vykreslování v průběhu makra - zvýší rychlost
Dim SBlok As Range, TBlok As Range
' zdrojovy list
Set SBlok = Worksheets(list).Range(oblast)
' cilovy list
Set TBlok = Worksheets("customers sumarry").Range(oblast_overall)
' kopirovat blok - hodnoty
TBlok.Value = SBlok.Value
Application.ScreenUpdating = True 'povolit vykreslování
End Sub

---

A to nastavení filtrů tam po vygenerování musí zůstat, nebo to může už být "nefiltrovaně"? Pokud máš problém jen s filtrama, tak bych jako první pomocí VBAčka na "zdrojových" listech vypnul filtr dat (z hlavy nevím, jak se to dělá, ale když si dáš záznam makra a tu operaci zrušení filtru provedeš, určitě ti to vyhodí smysluplný VBA kód).

Už jsem našel proceduru na vypnutí filtrů, díky za nasměrování! A ten problém s kopírováním byl způsobený tím, že hodnota proměnných SBlok a TBlok se musela po každém použití vymazat. Z nějakého důvodu bez vymazání nefungovala..


P.S. Kdybych mohl dát karmu tak dám, ale prý musím dát nejdřív někomu jinému, než budu moct zase tobě.. :-))

Jak vypínáš to filtrování?

Já jsem si teď pustil záznam maker a tam to vyplivlo tohle:

Selection.AutoFilter

(vypadá to, že tohle "přepíná" filtrování zap/vyp)

Problém ale je, že když dáš tohle "pro sichr" pustit na listu, který filtry nemá, tak ti je to naopak zapne, na druhou stranu, v defaultu zůstane vše zobrazené (pouhá aktivace filtru ti žádné řádky sama o sobě neskryje), tak by to nemuselo tak vadit.

Teď jsem chviličku googlil postup jak zjistit, jestli na listu je nebo není filtrování zapnuté, ale nic nefungovalo moc spolehlivě, zatím, proto se ptám, jestli jsi "neobjevil" něco lepšího? :-)

Tento kód dávám na začátek procedury a tím vypnu všechny filtry.

Citace:

---

Dim wshList As Worksheet

For Each wshList In Worksheets ' vymaže všechny filtry ve všech listech
If wshList.FilterMode Then wshList.ShowAllData
Next wshList

---

A takhle vypadá upravená procedura Kopie.

Citace:

---

Sub Kopie(oblast_overall As String, oblast As String, list As String) 'nakopiruje zadany list do overall
Application.ScreenUpdating = False 'zakázat vykreslování v průběhu makra - zvýší rychlost
Dim SBlok As Range, TBlok As Range
' zdrojovy list
Set SBlok = Worksheets(list).Range(oblast)
' cilovy list
Set TBlok = Worksheets("sumarry - do not touch!!").Range(oblast_overall)
' kopirovat blok - hodnoty
TBlok.Value = SBlok.Value

SBlok.Copy
TBlok.PasteSpecial (xlPasteFormats)

Set SBlok = Nothing
Set TBlok = Nothing

Application.ScreenUpdating = True 'povolit vykreslování
End Sub

---