tu je jedno riesenie, ale je dost pomale :)
Příloha: 
14547_test.zip (15kB, staženo 10x)
citovat14547_test.zip (15kB, staženo 10x)
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Tipy a triky pro Excel a makra VBA
< návrat zpět
Téma: Nalezení sloupců dle kritéria
MS Excel
Téma: Nalezení sloupců dle kritéria 
Zaslal/a 31.7.2013 10:10
Ahoj. Mohli byste mi prosím poradit s následujícím a ne asi složitým makrem ?
Mám označené sloupce slůvkem PRAVDA a NEPRAVDA.
Potřeboval bych najít všechny sloupce PRAVDA a
překopírovat je na list 1, jeden vedle druhého. Šlo by o určitou oblast.
Např. x5 - x20 kde x znamená určitý sloupec.
Moc děkuji za pomoc.
(31.7.2013 10:29)#014548
Pokud bych si mohl vymýšlet - je možné to nějak urychlit? V reálném případě budu mít více dat ( sloupců).
A ještě bych potřeboval, aby to nebralo celý sloupce, ale třeba jen řádky 5-10.
jinak děkujicitovat
A ještě bych potřeboval, aby to nebralo celý sloupce, ale třeba jen řádky 5-10.
jinak děkujicitovat
Smažte hodnoty NEPRAVDA (Ctrl+H)a označujte pouze sloupce ke kopírování (PRAVDA)
Pak lze použít -
.SpecialCells(xlConstants).EntireColumn.Copy
Pak je kód velmi rychlýcitovat
Pak lze použít -
.SpecialCells(xlConstants).EntireColumn.Copy
Pak je kód velmi rychlýcitovat
zkus, tohle, nic moc elegantního, ale celkem rychlé.
Řádky který se mají kopírovat nastavíš v makru.
Řádky který se mají kopírovat nastavíš v makru.
Příloha: 14550_copytrue.zip (19kB, staženo 10x)
citovat14550_copytrue.zip (19kB, staženo 10x)tu je to prerobene na copy // je to rychlejsie
Sub test()
y = 1
With Sheets("Table")
For x = 1 To .Cells(1, 1).CurrentRegion.Columns.Count
If .Cells(1, x).Value = "PRAVDA" Then
.Range(.Cells(1, x), .Cells(4, x)).Copy Sheets("NEW").Cells(1, y)
y = y + 1
End If
Next
End With
End Sub
je to na riadok od 1 do 4citovat
Sub test()
y = 1
With Sheets("Table")
For x = 1 To .Cells(1, 1).CurrentRegion.Columns.Count
If .Cells(1, x).Value = "PRAVDA" Then
.Range(.Cells(1, x), .Cells(4, x)).Copy Sheets("NEW").Cells(1, y)
y = y + 1
End If
Next
End With
End Sub
je to na riadok od 1 do 4citovat
Pokud můžu
@Opičák
Vždycky mě překvapíte ;)
Na jednu stranu jste schpen vymyslet pěkné věci a pak napíšete toto:
Sheets("List1").Select
Range(Cells(odRadku, colx), Cells(doRadku, colx)).Select
Selection.Copy
Sheets("List2").Select
Cells(1, n + Cells(1, Columns.Count).End(xlToLeft).Column).Select
ActiveSheet.Paste
Totéž Palooo
If Sheets("Table").Cells(1, x).Value = "PRAVDA" Then
tady přece stačí
If Sheets("Table").Cells(1, x).Value Then
funkčně to je sice správně - ale PRAVDA je přece hodnota typu Boolean
nebo místo For x se nabízí Foreach
@Opičák, @Palooo
Základem rychlého řešení je co nejméně přístupu na sešit
Tzn, načtěte oblast do proměnné typu Range a pak ji vložte jediným krokem
Když už to teda musíte řešit cyklem ;)
Omlouvám se, není to kritika, jen k zamyšlení...citovat
@Opičák
Vždycky mě překvapíte ;)
Na jednu stranu jste schpen vymyslet pěkné věci a pak napíšete toto:
Sheets("List1").Select
Range(Cells(odRadku, colx), Cells(doRadku, colx)).Select
Selection.Copy
Sheets("List2").Select
Cells(1, n + Cells(1, Columns.Count).End(xlToLeft).Column).Select
ActiveSheet.Paste
Totéž Palooo
If Sheets("Table").Cells(1, x).Value = "PRAVDA" Then
tady přece stačí
If Sheets("Table").Cells(1, x).Value Then
funkčně to je sice správně - ale PRAVDA je přece hodnota typu Boolean
nebo místo For x se nabízí Foreach
@Opičák, @Palooo
Základem rychlého řešení je co nejméně přístupu na sešit
Tzn, načtěte oblast do proměnné typu Range a pak ji vložte jediným krokem
Když už to teda musíte řešit cyklem ;)
Omlouvám se, není to kritika, jen k zamyšlení...citovat
To eLCHa: vychadzal som zo zadania kde bolo napisane ze stlpce su vyznacene slovami PRAVDA a NEPRAVDA ... takze musi to byt slovne
a k tomu SET-ovanie oblasti tak nato nemam mozgove bunky :))) musel by som viac literatury nastudovat .... hold som starej a lenivejcitovat
a k tomu SET-ovanie oblasti tak nato nemam mozgove bunky :))) musel by som viac literatury nastudovat .... hold som starej a lenivejcitovat
Abych jen nekritizoval, tak v opičákově příloze takto
s tím, že NEPRAVDA jsem vymazal
Sub Makro2()
Dim rToCopy As Range
Set rToCopy = Rows(1).SpecialCells(xlCellTypeConstants).EntireColumn
Dim rRowsToCopy As Range
Set rRowsToCopy = Range("2:6")
Set rToCopy = Intersect(rToCopy, rRowsToCopy)
rToCopy.Copy Sheets("List2").Cells(1)
Set rToCopy = Nothing
Set rRowsToCopy = Nothing
End Sub
Takže jsem schopen to zkopírovat jediným řádkem:
Intersect(Rows(1).SpecialCells(xlCellTypeConstants).EntireColumn, Range("2:6")).Copy Sheets("List2").Cells(1)citovat
s tím, že NEPRAVDA jsem vymazal
Sub Makro2()
Dim rToCopy As Range
Set rToCopy = Rows(1).SpecialCells(xlCellTypeConstants).EntireColumn
Dim rRowsToCopy As Range
Set rRowsToCopy = Range("2:6")
Set rToCopy = Intersect(rToCopy, rRowsToCopy)
rToCopy.Copy Sheets("List2").Cells(1)
Set rToCopy = Nothing
Set rRowsToCopy = Nothing
End Sub
Takže jsem schopen to zkopírovat jediným řádkem:
Intersect(Rows(1).SpecialCells(xlCellTypeConstants).EntireColumn, Range("2:6")).Copy Sheets("List2").Cells(1)citovat
@Palooo
vychadzal som zo zadania kde bolo napisane ze stlpce su vyznacene slovami PRAVDA a NEPRAVDA ... takze musi to byt slovne
Takže to nemusí být slovně ;) - PRAVDA je prostě true a NEPRAVDA je false ;)
Ale není to nic hrozného - jen je to zbytečné ťukání do klávesnicecitovat
vychadzal som zo zadania kde bolo napisane ze stlpce su vyznacene slovami PRAVDA a NEPRAVDA ... takze musi to byt slovne
Takže to nemusí být slovně ;) - PRAVDA je prostě true a NEPRAVDA je false ;)
Ale není to nic hrozného - jen je to zbytečné ťukání do klávesnicecitovat
To eLCHa: mne napriklad neprecita ako hodnotu boolean PRAVDA .... ked tam je napisane TRUE tak to precita
mozno je to koli tomu ze mam nemecky office
... ale zas nadruhu stranu ... to je tak ked programatorom dovolia nedefinovavat premenne .) flakaren hrubeho zrna :)))citovat
mozno je to koli tomu ze mam nemecky office
... ale zas nadruhu stranu ... to je tak ked programatorom dovolia nedefinovavat premenne .) flakaren hrubeho zrna :)))citovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články