MS Excel

Zdravím,
opět bych potřeboval pomoci s mým problémem.
Kompletní zadání problému je napsané přímo v sešitu u formuláře. Mám tabulku, formulář pro zpracování cenových nabídek. Potřeboval bych funkci pro posun řádků nahoru a dolu a pro přidání nového řádku. Zde není možné z důvodu fixní velikosti formuláře a vzorců, přidávat řádky klasicky, ale potřeboval bych posouvat hodnoty na řádcích směrem nahoru a dolu. Je to klasická editace položek, tak jako u klasických účetních a kalkulačních programů. Je toto reálné a pomohl by mě někdo s touto funkcí? Děkuji za každou pomoc.Martin

Zaslat odpověď >

Strana: 1 2 další »

eLCHa(1.9.2014 7:53)#021380

Jen v rychlosti.
Pro posun řádků bych použil něco jako:Sub subMove(iRows As Long)
ActiveCell.EntireRow.Cut
ActiveCell.Offset(iRows - (iRows > 0), 0).EntireRow.Insert Shift:=xlDown
ActiveCell.Offset(iRows, 0).Select
End Sub

Sub subUp()
Call subMove(-1)
End Sub

Sub subDown()
Call subMove(1)
End SubNa Vaší příloze mi to ovšem neposunulo ty zelené šípky (které bych mimochodem nepoužil).
Vložení řádku třeba:Sub subInsert()
With ActiveCell.EntireRow
.Copy
.Insert Shift:=xlDown
.Offset(-1, 0).SpecialCells(xlCellTypeConstants).ClearContents
End With 'ActiveCell.EntireRow
End Sub

Tyto kódy neřeší omezení horní a dolní hranice, nicméně to by neměl být problém např. pomocí pojmenované oblasti a testu, zda se nacházím na jejím prvním nebo posledním řádku.

Ještě poznámka - pokud tyto kódy spustíte někde uprostřed oblasti, vzorce pod se aktualizují automaticky. Pokud byste ovšem přidal řádek před první nebo za poslední, nebudou se aktualizovat. Toto řeším tak, že vzorce pod tabulkou rozšířím o jeden řádek nad a jeden řádek pod oblast, kde se budou vkládat řádky a nemusím to řešit v kódu.citovat

kp57(1.9.2014 22:03)#021394

Taky něco přidám pro inspiraci. Ty šipky, jak říká eLCHa. Spíš bych napsal prc. pro místní nabídku. Dal jsem tam na ovládání "OnKey".

Příloha: rar

21394_nabidka2.rar (255kB, staženo 22x)

citovat

marficek119(1.9.2014 22:21)#021396

Díky za radu, mrknu na to a vyzkouším.
TO kp57, díky, podívám se na tocitovat

kp57(1.9.2014 22:30)#021397

List Nabidka:
CTRL INSERT
CTRL DELETE
CTRL ŠIPKA NAHORU
CTRL ŠIPKA DOLUcitovat

marficek119(1.9.2014 22:40)#021398

JJ, děkuji, již jsem si to v kódu přečetl. Ještě tedy, půjde tyto funkce přiřadit ke tlačítkům.S tímto souborem bude pracovat více lidí a hlavně mám na klávesnici Delete a Insert pod jednou klávesou :-(citovat

kp57(1.9.2014 22:46)#021399

Jak říkám, vytvořil bych místní nabídku(pravé tlč. myši). Ale samozřejmě se mohou ty prc. přiřadit jakýmkoliv tlačítkům.citovat

marficek119(1.9.2014 22:56)#021400

Pravé tlačítko myši je super nápad, jen to sám nezrealizuji. Jediné co mě napadlo, je přiřadit dané funkce pod připravená tlačítka.
Pomohl bys s tou místní nabídkou? Jinak co jsem zkoušel, tak to maká perfektněcitovat

kp57(1.9.2014 23:21)#021401

Jen tak narychlo

Příloha: rar

21401_nabidka2.rar (252kB, staženo 17x)

citovat

kp57(1.9.2014 23:58)#021402

Trochu upravené

Příloha: rar

21402_nabidka2.rar (256kB, staženo 19x)

citovat

eLCHa(2.9.2014 8:32)#021405

@kp57
dovolím si jednu technickou a dvě faktické poznámky.
Technická:
Použití If podmínka Then Goto label
'kód
label:
není to špatně a vlastně nemám žádný argument proti - snad jen přehlednost - používámIf Not podmínka Then
'kód
End If

Faktická 1:
protože se v tabulce vyskytují vzorce, nefunguje Vám to správně. Protože jste nezadal, co chcete s oblastí dělat (nedávno se tu řešilo), použil kompilátor vlastnost Value a převedl vzorce na hodnoty. Proto by bylo lepší použít .FormulaR1C1

Faktická 2:
Napsal jste 2 stejné procedury - Posun_Nahoru a Posun_Dolu. To samozřejmě nevadí, ale ve chvíli, kdy zjistíte, že chcete něco změnit, budete to muset dělat 2x. Proto je lepší napsat jednu a tu volat.

Váš upravený kód, kde vše ukazujiPrivate Sub Posun_Nahoru()
Call Posun(-1)
End Sub

Private Sub Posun_Dolu()
Call Posun(1)
End Sub

Private Sub Posun(Radky As Long)
Call Zrob_Start

If Union(Selection, rngTab).Address = rngTab.Address Then
Dim rdR As Long
rdR = ActiveCell.Row
If Not rdR = rdFirst Then
Dim xPolozka As Variant, yPolozka As Variant
xPolozka = Intersect(Rows(rdR), rngTab).FormulaR1C1
yPolozka = Intersect(Rows(rdR + Radky), rngTab).FormulaR1C1

With WorksheetFunction
Intersect(Rows(rdR + Radky), rngTab).FormulaR1C1 = .Transpose(.Transpose(xPolozka))
Intersect(Rows(rdR), rngTab).FormulaR1C1 = .Transpose(.Transpose(yPolozka))
End With 'WorksheetFunction

ActiveCell.Offset(Radky, 0).Select
End If
End If

Call Zrob_Konec
End Subcitovat

Strana: 1 2 další »

Téma: Posun řádků

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje