Sub Neshoda()
Dim D(), N() 'pole Dodacích listů a pole Neshod
Dim ColD As Collection 'kolekce Dodacích listů, vhodná pro rychlé ověření zda kolekce danou položku obsahuje
Dim Item 'dohledaná položka z předešlé kolekce ColD, položka se na nic nepoužije, slouží jenom na prípadné vyvolání chyby, co ověří existenci
Dim RadkuD As Long, RadkuN As Long 'počty řádků v Dodacích listech a v Neshodách, slouží k určení velikosti polí, do kterých se načtou data
Dim i As Long 'iterační proměnná pro cyklus
Dim RNG As Range 'oblast, která se bude mazat, postupně se do ní přidávají neshodné řádky
With Sheets("Dodáky") 'pracuj s listem "Dodáky", následně se použije tečková notace, určuje práci s nadřazeným objektem ve "With", napr: .Cells()
RadkuD = .Cells(Rows.Count, 1).End(xlUp).Row - 1 'zjisti počet řádkú Dodáků v sloupci 1 (A) {nalezne poslední vyplněný řádek - hlavička}
Select Case RadkuD 'podle počtu řádků vykonej akci
Case 0: MsgBox "Žádné dodací listy", vbExclamation: Exit Sub 'když nejsou Dodáky, oznam a odchod
Case 1: ReDim D(1 To 1, 1 To 1): D(1, 1) = .Cells(2, 1).Value 'při načtení dat o velikosti 1 položky do pole, je nutné definovat nejdřív velikost pole, pak do 1. položky načíst bunku
Case Else: D = .Cells(2, 1).Resize(RadkuD).Value 'při více jak 1 položce pak stačí jenom načíst všechny bunky o patřičné výšce (RadkuD) do prázdného pole
End Select
End With 'ukonči práci s listem Dodáky
'totéž jako s Dodáky provedeme s načtením Neshod do pole N
With Sheets("Neshoda")
RadkuN = .Cells(Rows.Count, 1).End(xlUp).Row - 1
Select Case RadkuN
Case 0: MsgBox "Žádné neshodné dodací listy", vbExclamation: Exit Sub
Case 1: ReDim N(1 To 1, 1 To 1): N(1, 1) = .Cells(2, 1).Value
Case Else: N = .Cells(2, 1).Resize(RadkuN).Value
End Select
Set ColD = New Collection 'vytvoří se objekt, nová prázdná kolekce, potřebné pro vytvoření vyhledávacího "seznamu" dodáků
For i = 1 To RadkuD 'projdeme cyklem celé pole Dodáky, a každý dodák přidáme do kolekce pod vyhledávacím klíčem, co je císlo Dodáku převedené na řetezec CStr(D(i, 1))
'samotný údaj v kolekci je irelevantní, ale je potřebné metodě .Add předat i první parametr, ale ten múže být klidně 0 apod.
ColD.Add D(i, 1), CStr(D(i, 1)) 'pridání vyhledávacích klíču do kolekce
Next i
On Error Resume Next 'tady přebíráme odchycení chyb, protože pri nenalezení položky Neshody ve vyhledávaci kolekci Dodáků, by vznikla chyba makra, toho využijeme a chybu použijeme na mazání
For i = 1 To RadkuN 'projdeme cyklem celé pole Neshody
Item = ColD(CStr(N(i, 1))) 'TADY JE TA SRANDA - podle vyhledávacího klíče, který teď vytvoří převod Neshody na řetezec CStr(N(i, 1)), skusíme najít v kolekci Dodák, případný nález
'se přiřadí do proměnné Item - irelevantní. Při tom ale, když najde tak chyba Err je 0, ale když nenajde vyvolá se chyba Err, a to testujeme
If Err.Number <> 0 Then 'když nastala ve vyhledání Neshody mezi Dodáky chyba, znamená to, že takový Dodák není, a teda řádek v Neshody bude přiřazen následně do mazané oblasti
If RNG Is Nothing Then Set RNG = .Cells(i + 1, 1) Else Set RNG = Union(RNG, .Cells(i + 1, 1)) 'když je oblast mazání prázdná tak nastav bunku ze sloupce 1 (A) a řádku podle iterační
'proměnné cyklu "i" + hlavička, tedy .Cells(i + 1, 1)
'používamé skrácenou tečkovou notaci .Cells() protože jsme stále pod nadřazením objektem ve With
'když oblast RNG prázdná není, tedy uý som v ní zaznamenány nějaké bunky na mazání, jenom
'k ní pomocí Unio() přidej další. Je to vhodné právě pro hromadné akce s nesouvislími oblastmi
Err.Clear 'po odchycení a spracování chyby, ji musíme zmazat, protože by jinak nastalo mazání nesprávné oblasti i když by následné hledáni prošlo a chybu by samo o sobě nevracelo
End If
Next i
On Error GoTo 0 'po dokončení celého cyklu vypneme odchytávání chyb makra
End With 'ukonči práci s listem Deshody
If Not RNG Is Nothing Then RNG.EntireRow.Delete 'jestli byli do mazané oblasti přiřazené nejaké bunky Neshod, celé řádky najednou vymaž
Set ColD = Nothing 'i když to VBA dělá většinou automaticky po skončení procedury, je vhodné objekty z paměti zmazat
End Sub
Dim D(), N() 'pole Dodacích listů a pole Neshod
Dim ColD As Collection 'kolekce Dodacích listů, vhodná pro rychlé ověření zda kolekce danou položku obsahuje
Dim Item 'dohledaná položka z předešlé kolekce ColD, položka se na nic nepoužije, slouží jenom na prípadné vyvolání chyby, co ověří existenci
Dim RadkuD As Long, RadkuN As Long 'počty řádků v Dodacích listech a v Neshodách, slouží k určení velikosti polí, do kterých se načtou data
Dim i As Long 'iterační proměnná pro cyklus
Dim RNG As Range 'oblast, která se bude mazat, postupně se do ní přidávají neshodné řádky
With Sheets("Dodáky") 'pracuj s listem "Dodáky", následně se použije tečková notace, určuje práci s nadřazeným objektem ve "With", napr: .Cells()
RadkuD = .Cells(Rows.Count, 1).End(xlUp).Row - 1 'zjisti počet řádkú Dodáků v sloupci 1 (A) {nalezne poslední vyplněný řádek - hlavička}
Select Case RadkuD 'podle počtu řádků vykonej akci
Case 0: MsgBox "Žádné dodací listy", vbExclamation: Exit Sub 'když nejsou Dodáky, oznam a odchod
Case 1: ReDim D(1 To 1, 1 To 1): D(1, 1) = .Cells(2, 1).Value 'při načtení dat o velikosti 1 položky do pole, je nutné definovat nejdřív velikost pole, pak do 1. položky načíst bunku
Case Else: D = .Cells(2, 1).Resize(RadkuD).Value 'při více jak 1 položce pak stačí jenom načíst všechny bunky o patřičné výšce (RadkuD) do prázdného pole
End Select
End With 'ukonči práci s listem Dodáky
'totéž jako s Dodáky provedeme s načtením Neshod do pole N
With Sheets("Neshoda")
RadkuN = .Cells(Rows.Count, 1).End(xlUp).Row - 1
Select Case RadkuN
Case 0: MsgBox "Žádné neshodné dodací listy", vbExclamation: Exit Sub
Case 1: ReDim N(1 To 1, 1 To 1): N(1, 1) = .Cells(2, 1).Value
Case Else: N = .Cells(2, 1).Resize(RadkuN).Value
End Select
Set ColD = New Collection 'vytvoří se objekt, nová prázdná kolekce, potřebné pro vytvoření vyhledávacího "seznamu" dodáků
For i = 1 To RadkuD 'projdeme cyklem celé pole Dodáky, a každý dodák přidáme do kolekce pod vyhledávacím klíčem, co je císlo Dodáku převedené na řetezec CStr(D(i, 1))
'samotný údaj v kolekci je irelevantní, ale je potřebné metodě .Add předat i první parametr, ale ten múže být klidně 0 apod.
ColD.Add D(i, 1), CStr(D(i, 1)) 'pridání vyhledávacích klíču do kolekce
Next i
On Error Resume Next 'tady přebíráme odchycení chyb, protože pri nenalezení položky Neshody ve vyhledávaci kolekci Dodáků, by vznikla chyba makra, toho využijeme a chybu použijeme na mazání
For i = 1 To RadkuN 'projdeme cyklem celé pole Neshody
Item = ColD(CStr(N(i, 1))) 'TADY JE TA SRANDA - podle vyhledávacího klíče, který teď vytvoří převod Neshody na řetezec CStr(N(i, 1)), skusíme najít v kolekci Dodák, případný nález
'se přiřadí do proměnné Item - irelevantní. Při tom ale, když najde tak chyba Err je 0, ale když nenajde vyvolá se chyba Err, a to testujeme
If Err.Number <> 0 Then 'když nastala ve vyhledání Neshody mezi Dodáky chyba, znamená to, že takový Dodák není, a teda řádek v Neshody bude přiřazen následně do mazané oblasti
If RNG Is Nothing Then Set RNG = .Cells(i + 1, 1) Else Set RNG = Union(RNG, .Cells(i + 1, 1)) 'když je oblast mazání prázdná tak nastav bunku ze sloupce 1 (A) a řádku podle iterační
'proměnné cyklu "i" + hlavička, tedy .Cells(i + 1, 1)
'používamé skrácenou tečkovou notaci .Cells() protože jsme stále pod nadřazením objektem ve With
'když oblast RNG prázdná není, tedy uý som v ní zaznamenány nějaké bunky na mazání, jenom
'k ní pomocí Unio() přidej další. Je to vhodné právě pro hromadné akce s nesouvislími oblastmi
Err.Clear 'po odchycení a spracování chyby, ji musíme zmazat, protože by jinak nastalo mazání nesprávné oblasti i když by následné hledáni prošlo a chybu by samo o sobě nevracelo
End If
Next i
On Error GoTo 0 'po dokončení celého cyklu vypneme odchytávání chyb makra
End With 'ukonči práci s listem Deshody
If Not RNG Is Nothing Then RNG.EntireRow.Delete 'jestli byli do mazané oblasti přiřazené nejaké bunky Neshod, celé řádky najednou vymaž
Set ColD = Nothing 'i když to VBA dělá většinou automaticky po skončení procedury, je vhodné objekty z paměti zmazat
End Sub
Příloha: 
49127_promazani-neshod-dodacich-listu.zip (20kB, staženo 15x)
citovat49127_promazani-neshod-dodacich-listu.zip (20kB, staženo 15x)
RSS nejnovější články