MS Excel

Zdravim potreboval bych pomoct s jednim makrem které by umelo z dane oblasti A2:CV10000 kde kdekoli muzou byt vyplnene cisla. Cilem je všechny cisla z oblasti vypsat pod sebe do jednoho sloupce na novy list CIL. viz Příloha. Děkuji za případné rady

Zaslat odpověď >

elninoslov(1.2.2019 17:25)#042622

Možno aj takto. Ale radšej by som zisťoval počet riadkov a stĺpcov, ako to mať na pevno.
Sub VypisCisla()
Dim D(), Sloupcu As Integer, Radku As Long, y As Long, x As Integer, Col As New Collection, Polozka

Sloupcu = 100
Radku = 10000
ReDim D(1 To Radku, 1 To Sloupcu)
D = Worksheets("VSTUP").Cells(2, 1).Resize(Radku, Sloupcu).Value

On Error Resume Next
For x = 1 To Sloupcu
For y = 1 To Radku
If LenB(D(y, x)) > 0 Then
If IsNumeric(D(y, x)) Then Col.Add D(y, x)
End If
Next y
Next x
On Error GoTo 0

With Worksheets("CIL")
.Columns(1).ClearContents
Radku = Col.Count
If Radku > 0 Then
ReDim D(1 To Radku, 1 To 1)
y = 0
For Each Polozka In Col
y = y + 1
D(y, 1) = Polozka
Next Polozka
.Cells(1, 1).Resize(Radku, 1).Value = D
End If
End With
End Sub

Příloha: zip

42622_vsetky-cisla.zip (306kB, staženo 17x)

citovat

Stalker(1.2.2019 19:04)#042623

Šel sem na to bez kolekce, tak to snad nebude úplně mimo mísu

Příloha: zip

42623_vba-podsebe.zip (302kB, staženo 17x)

citovat

elninoslov(2.2.2019 1:44)#042625

Redim poľa a následné Transpose som nepoužil naschvál, kvôli možnosti, že v takom množstve buniek môže byť ľahko aj 32767 hodnôt. No a tam Transpose končí.

EDIT: A ešte treba dať pozor, a vybrať si správne verziu podľa potrieb. Rozdiel je napr. aj v tom, kolegove makro ide zľava doprava, a ak je prázdna cyklus končí. Ja som sa držal zadania, že hodnota môže byť hocikde, nielen zľava.citovat

Stalker(2.2.2019 11:46)#042626

elninoslov napsal/a:

EDIT: A ešte treba dať pozor, a vybrať si správne verziu podľa potrieb. Rozdiel je napr. aj v tom, kolegove makro ide zľava doprava, a ak je prázdna cyklus končí. Ja som sa držal zadania, že hodnota môže byť hocikde, nielen zľava.

To je pravda, vycházel sem z přiloženého souboru, kde se v řádcích nevyskytují mezery mezi hodnotami. Proto sem volil cestu opuštění cyklu a přechodu na další řádek.

Jo a objevil sem chybu v kódu.
Místo:
.Cells(1, 1).Resize(UBound(arrSloupec)) = Application.Transpose(arrSloupec)
Má být:
.Cells(1, 1).Resize(UBound(arrSloupec) + 1) = Application.Transpose(arrSloupec)citovat

Merlin99(3.2.2019 21:20)#042645

elninoslov, Stalker: DÍKY moc funguje skvele, jen jsem dosel nyni k zaveru ze tu logiku potrebuju trosku komplikovanejsi. Jde oto ze na listu VSTUP ve slopci A jsou jinaci cisla. Potreboval bych tedy na list cil pridat druhy sloupcec ve kterem by bylo vzdy cislo ze sloupce A a vedle ve sloupci nej vsechny cisla ktere obsahuje v radku. Cislo ze sloupce A by tedy bylo ve slouci vzdy duplicitne ke vsem zaznamu co by se nasli na dalsich bunkach daneho radku.

citovat

elninoslov(3.2.2019 23:17)#042646

Teda sa majú vypísať iba tie riadky dát, v ktorých je od stĺpca B aspoň 1 nejaké číslo ? A ak tam je, tak vo výsledku bude v A najskôr číslo z A zdroja (nejaké ID), a vedľa postupne pod sebou čísla z B:CV, a to tak, že sa V A opakuje stále to isté ID, ktoré im náleží z riadku zdroja ?

Z toho mi vyplýva, že riadky, ktoré majú iba ID v stĺpci A, a nemajú žiadne ďalšie čísla v B:CV, sa do výsledku zahrnúť nemajú. Je to tak ?

Platí teda, že sa prehľadávanie riadku zdroja končí v momente nájdenia 1. nečísla v B:CV ? Alebo sa musí vždy prehľadať celý riadok B:CV ? Proste či sú v riadku medzery.

Ak je to inak, dajte konkrétny príklad, ako sa majú vyhodnotiť načrtnuté situácie.

Tu je nástrel.
Sub VypisCisla()
Dim D(), Sloupcu As Integer, Radku As Long, y As Long, x As Integer, Col As New Collection, Polozka, Cisla() As Double, PocetCisel As Long, RadkuCelkem As Long, SloupcuCelkem As Integer

Sloupcu = 100
Radku = 10000
ReDim D(1 To Radku, 1 To Sloupcu)
D = Worksheets("VSTUP").Cells(2, 1).Resize(Radku, Sloupcu).Value

On Error Resume Next
For y = 1 To Radku
PocetCisel = -1
For x = 2 To Sloupcu
If LenB(D(y, x)) > 0 Then
If IsNumeric(D(y, x)) Then
PocetCisel = PocetCisel + 1
ReDim Preserve Cisla(PocetCisel)
Cisla(PocetCisel) = D(y, x)
End If
End If
Next x
If PocetCisel > -1 Then
Col.Add Array(D(y, 1), Cisla)
RadkuCelkem = RadkuCelkem + PocetCisel + 1
If PocetCisel > SloupcuCelkem Then SloupcuCelkem = PocetCisel
End If
Next y
On Error GoTo 0

With Worksheets("CIL")
.UsedRange.ClearContents
If RadkuCelkem > 0 Then
ReDim D(1 To RadkuCelkem, 1 To SloupcuCelkem + 1)
y = 0
For Each Polozka In Col
For x = 0 To UBound(Polozka(1))
y = y + 1
D(y, 1) = Polozka(0)
D(y, 2) = Polozka(1)(x)
Next x
Next Polozka
.Cells(1, 1).Resize(RadkuCelkem, SloupcuCelkem + 1).Value = D
End If
End With
End Sub

Příloha: zip

42646_vsetky-cisla-2.zip (307kB, staženo 19x)

citovat

Merlin99(4.2.2019 8:47)#042647

elninoslov: Udělal jsi to přesně jak jsem měl na mysli, TOP TOP DÍKY MOC ulehčí to spousty práce díky.

citovat

elninoslov(4.2.2019 12:47)#042650

Ešte som Vám urobil malú zmenu:

-Odstránil som zabudnutú premennú na kontrolu počtu výsledkových stĺpcov, lebo ak to je takto, tak sú vždy len 2.
-Počet riadkov a stĺpcov ku kontrole sa určuje podľa A:A a 1:1.
-Urobil som nejakú kontrolu na neexistenciu dát.
-A hlavne som Vám detailne popísal každý riadok kódu, aby ste možno aj porozumel tomu, ako to funguje. To je dôležité, aby ste vedel povedať prípadne, že sme vyradili dáta, ktoré mali byť validné.
-V zdrojových dátach ste mal v bunkách B2344, B3326, B4171 to číslo ako text. Dáta by mali byť konzistentné.
-V kóde je zakomponovaná možnosť ukončenia/pokračovania kontroly v riadku pri nájdení prázdnej bunky. Popis v kóde - hľadajte ####

Pekný deň :)

Příloha: zip