< návrat zpět

MS Excel


Téma: Prohledat rss

Zaslal/a 4.12.2020 5:16

Ahoj.
Potřeboval bych poradit jak přejít na další hledané číslo.

V sešitu dva listy "Dodáky" a "Neshoda".
V listě "Dodáky" je seznam čísel, které hledám v listě "Neshoda" a pokud toto číslo najdu tak číslo na listě "Neshoda" zůstane.

Pokud ho však nenajdu, tak smaže řádek. Takto prohledám celý list "Neshoda"

Po sem to zvládám.

Nevím ale jak přejít na další číslo v listě "Dodáky". Seznam hledaných čísel má vždy jiny počet čísel a jiná čísla.

Základní procedura:
Sub Neshoda()
Dim radek As Integer
Dim posledni As Long
posledni = Sheets("Neshoda").Cells(Rows.Count, 1).End(xlUp).Row

For radek = 2 To posledni

If Sheets("Neshoda").Range("A" & radek).Value2 = Sheets("Dodáky").Range("A1").Value2 Then

ElseIf Sheets("Neshoda").Range("A" & radek).Value2 <> Sheets("Dodáky").Range("A1").Value2 Then
Sheets("Neshoda").Range("A" & radek).EntireRow.Delete

End If
Next
End Sub


Pomůžete prosím někdo?
Děkuji

Příloha: zip49126_porovnat.zip (16kB, staženo 7x)
Zaslat odpověď >

#049127
elninoslov
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
Příloha: zip49127_promazani-neshod-dodacich-listu.zip (20kB, staženo 7x)
citovat
#049136
avatar
Elninoslov děkuji za pomoc, pracuje dle očekáváni.
Nicméně musím konstatovat že to co jsi napsal je pro mě Španělská vesnice a tak bych chtěl ještě požádat, zda by šlo nějak rozepsat?

Pokud ne, nic se neděje.
I tak děkuji.citovat
#049138
elninoslov
Vymenil som kód aj prílohu v predošlom príspevku. Ja to lepšie opísať neviem. Opis trval dlhšie ako programovanie 2citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

excel se mi pokakal nefunguje funkce roztažení

lugr • 24.1. 8:21

excel se mi pokakal nefunguje funkce roztažení

Fantasyk • 23.1. 21:57

hromadne doplnenie ciarky

marjankaj • 22.1. 20:11

hromadne doplnenie ciarky

michalko • 22.1. 19:49

Tabulka dovolených 2021

lugr • 22.1. 17:59

Tabulka dovolených 2021

00001 • 22.1. 15:38

řazení dat - Makro nereaguje změnu v daném listu

elninoslov • 22.1. 13:15