• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

Ak je to k predošlej prílohe tak tam je "signifikantný" asi stĺpec B - Vypln2.
Ak je to niečo iné tak končí na "xxx" - Vypln3

Skúste parameter 21 namiesto 2.

Popravde nepoznám odpoveď na to, prečo PasteSpecial nefachá v tomto prípade. Každopádne ak to dáte priamo ako parameter Destination tak to ide:
Range("C" & radek).Offset(0, -2).Range("A1:Z1").Cut Sheets("Obaly").Cells(65536, 1).End(xlUp).Offset(1, 0)

Vyriešil by som to inak. Nie jednotlivé Cut, ale hromadné Copy.
Len si vyberte a aktivujte na konci jednu z možností:
rngCopy.ClearContents 'smaže obsah buněk
rngCopy.Clear 'smaže obsah a formátování buněk
rngCopy.EntireRow.Delete 'odstraní řádky
Celé makro Obaly2:
Sub Obaly2()
Dim Radek As Long
Dim RadkuC As Long, C()
Dim rngCopy As Range

'načíst data ze sloupce C
With Worksheets("Data")
RadkuC = .Cells(Rows.Count, 1).End(xlUp).Row - 1
Select Case RadkuC
Case 0: MsgBox "Žádné data", vbExclamation: Exit Sub
Case 1: ReDim C(1 To 1, 1 To 1): C(1, 1) = .Cells(2, "C").Value2
Case Else: C() = .Cells(2, "C").Resize(RadkuC).Value2
End Select

'proleze údaje ze sloupce C
For Radek = 1 To RadkuC
Select Case C(Radek, 1)
Case "8100", "8200", "8300" 'když je požadovaný údaj, přidej do multioblasti ke skopírování
If rngCopy Is Nothing Then Set rngCopy = .Range("A1:Z1").Offset(Radek, 0) Else Set rngCopy = Union(rngCopy, .Range("A1:Z1").Offset(Radek, 0))
Case Else
End Select
Next Radek
End With

If Not rngCopy Is Nothing Then
rngCopy.Copy Worksheets("Obaly").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 'skopíruje jednorázově všechny validní bunky
'rngCopy.ClearContents 'smaže obsah buněk
'rngCopy.Clear 'smaže obsah a formátování buněk
'rngCopy.EntireRow.Delete 'odstraní řádky
End If
End Sub
Rýchlostne to bude podstatne lepšie. Len skúste či to fachá aj u Vás. Malo by.

A doplňte si ešte pod
Case Else
čo sa má diať ak je hodnota iná ako tie vybrané. To nemáte vo svojom makre špecifikované.

Mne to normálne funguje:
Sub Copy_pokus()
Sheets("pokus").Range("2:2").Copy
Sheets("Obaly").Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End Sub
Office 2019 x64 SK Pro, Win 10 x64 Sk Pro v1909
Uveďte väčší kus kódu, najlepšie prílohu - súbor.

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

Už to tu tuším niekto písal, že to inak nejde.
Makro nemusí byť v žiadnom jeho zošite. Môže sa dať ako univerzál do PERSONAL.XLSB, a volať čudlíkom v lište nad práve otvoreným zošitom. Teda jeho súbory budú bez makra.

Čo ja by som tiež všetko chcel ...

Na spojenie dvoch Range by som použil Union, a tým pádom by všetko aj s ClearContents prebehlo v jednom kroku.

Pokus

Čítanie s porozumením je fenomén dnešnej doby. Totiž konkrétne jeho presný opak :)
marjankaj Vám písal, aby ste dal prílohu s tým čo máte, a potom ukázal, ako má to isté vyzerať po úprave. Vy píšete, že "toto" je na začiatku, a následne napíšete, že to je výsledok :)

No neva. Vidím to zatiaľ takto:
Máte nejakú šablónu, list kde nič nieje, iba správne nastavené formáty, nič nieje zlúčené.
Do tohto listu nakopírujete/importujete hodnoty (iba hodnoty).
Máte nejaký určovací stĺpec (asi A), podľa ktorého sa určuje, ktoré riadky sa budú zlučovať. Rovnaké číslo v stĺpci A sa zlučuje. Ak je tam pod sebou 5 rovnakých, znamená, že sa zlúči týchto 5 riadkov v A.
Podľa týchto 5-ich rovnakých riadkov zo stĺpca A, zlučujeme samostatne aj stĺpce C, J - AA, ale iba v prípade, že medzi tými 5-imi riadkami daného stĺpca sú vôbec nejaké data. Teda napr v P6:10 nie sú data, tak sa nezlučujú, ale v P2:P4 sú data, tak sa zlúčia.
A čo s dátami "- - -" v S,V,Y ?

A teraz ešte k zlúčeným riadkom. Prečo sa nezlučuje stĺpec B (veď má rovnaké dáta)?

Ďalej vo vyššie menovaných stĺpcoch, ktorých sa zlučovanie týka, môže nastať, aby napr. v P6:P10 boli rôzne dáta? Teda nie rovnaké? V tom prípade nie zlúčiť (Merge), ale najskôr spojiť (Join) a následne Merge. Teda viac riadkov v jednej bunke. S takýmito bunkami sa nebude dať potom už pracovať v zmysle súčtov, počtov, filtrov a pod. A navyše je možné že tieto spojené a následne zlúčené dáta a bunky budú mať iný formát (číslo+text alebo červené+zelené a pod)? To by bolo riešiteľné dosť komplikovane, pretože by sa museli prechádzať takmer všetky mysliteľné možnosti formátu, farby, písma a ... Rôznorodý Podmienený formát by samozrejme logicky nemohol nikdy fungovať.

Snáď bude teraz komunikácia zrozumiteľnejšia, lebo podľa mňa nieje jasné o čo ide.

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

Vzorec pomocou FREQUENCY/ČETNOSTI. V príklade 2 nerozumiem, prečo má byť pri vyradených výsledok 2. Pretože mne logicky pripadá, že každý vyradený riadok diskvalifikuje sám seba. Teda 0 :)
Ale to PQ/KT bude OK.

príklad:
Sub vyber()
Dim OsobniCislo As String, Jmeno As String

ZADAJ:
OsobniCislo = InputBox("Zadej osobní číslo:")
If StrPtr(OsobniCislo) = 0 Then Exit Sub
If Not IsNumeric(OsobniCislo) Then GoTo ZADAJ
On Error Resume Next
Jmeno = Application.WorksheetFunction.VLookup(CDbl(OsobniCislo), Range("Skupina"), 2, 0)
If Err.Number <> 0 Then
Err.Clear
GoTo ZADAJ
Else
With Worksheets("List1")
.Range("OsobniCislo").Value = CDbl(OsobniCislo)
.Range("Jmeno").Value = Jmeno
End With
End If
On Error GoTo 0
End Sub

Zaujímavý nápad, ako ľahko určovať, ktoré bunky zahrnúť, len nevieme podrobnosti.
Ako prichádza k aktualizácii (či by bolo pracné ich takto "transponovať")?
Menia sa tie bunky za iné?
Aké sú podmienky, ktoré započítať a ktoré nie (na základe nejakých podmienok sa predsa zazelenajú)?
...

A ako prídete na to, že práve iba z týchto buniek sa bude vždy robiť priemer???

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse