Stránka 1 z 1
Makro na převod jednotek
Napsal: 19 kvě 2014 21:15
od pavel_sch
Dobrý den,
potřeboval bych poradit s tvorbou makra na převod jednotek.
V podstatě jde jenom o to vydělit všechny buňky, které mají ve formátování nastaveno "účetnický", buňkou, kterou mám na jiném listě.
A zároveň se chci zeptat, jestli to jde nějak zakomponovat i do kontingenční tabulky, tedy aby se mi při spuštění makra všechny hodnoty převedly do jiných jednotek?
Nevím jak moc složité to je nebo není, každopádně budu vděčný za případnou pomoc.
Re: Makro na převod jednotek
Napsal: 20 kvě 2014 01:23
od lubo.
Nestačí vzorec?
=KDYŽ(ZLEVA(POLÍČKO("formát";A1);1)="C";"Buňka na jiném listě";A1)
Do kont tabulky stačí potom přidat sloupec.
Re: Makro na převod jednotek
Napsal: 20 kvě 2014 07:38
od pavel_sch
Bohužel vzorec nestačí, změna jednotek není trvalá, a přidávat další sloupec se mi také nehodí, jelikož už tak je tabulka dost nafouklá, a přidávat další sloupce by jí udělalo ještě přifouklejší.
Přes záznam maker jsem došel k tomuto.
Sub EUR()
'
' EUR Makro
'
'
Columns("B:D").Select
Selection.NumberFormat = _
"_-* #,##0.00 [$€-1]_-;-* #,##0.00 [$€-1]_-;_-* ""-""?? [$€-1]_-;_-@_-"
End Sub
Což mi v podstatě změní znak měny, teď ještě nějak zakomponovat ono vydělení.
A také to více zobecnit. aby to nebyly předem nadefinované sloupce, ale ty které jsou formátované jako účetnické.
Re: Makro na převod jednotek
Napsal: 30 čer 2014 20:46
od cmuch
Tady je makro co převede všechny sloupce které mají formát jako účetnický
na měnu která je zadaná v A1 a vydělí číslem co je zadané hned vedle v B1 (viz. makro)
Upozornění:po překopírování do makra nejspíše bude znak libry jako L
[$L-809], nahraď pomocí české klávesnice - pravýALT+L
Kód: Vybrat vše
Sub PrevodMeny()
' Prevod meny v sloupec aktivni list format ucetnictvi
'
Dim clmNumFormatNew
Dim clmSh As Range
Dim vMena As Range
'
For Each clmSh In ActiveSheet.Columns
If InStr(Left(clmSh.NumberFormat, 1), "_") > 0 Then
'co se ma nastavit jako mena (v bunce A1 vyberovy seznam /CZK/EUR/USD/GPD/ )
clmNumFormatNew = Sheets("nastaveni").Cells(1, 1)
'cim delit hodnoty aby byly pro novou menu [B1]
Set vMena = Sheets("nastaveni").Cells(1, 2)
vMena.Copy
Select Case clmNumFormatNew
Case "CZK"
clmSh.PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
clmSh.NumberFormat = "_($* #,##0_);_($* (#,##0);_($* ""-""_);_(@_)"
Case "EUR"
clmSh.PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
clmSh.NumberFormat = "_-[$€-2] * #,##0.00_-;-[$€-2] * #,##0.00_-;_-[$€-2] * ""-""??_-;_-@_-"
Case "USD"
clmSh.PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
clmSh.NumberFormat = "_-[$$-409]* #,##0.00_ ;_-[$$-409]* -#,##0.00 ;_-[$$-409]* ""-""??_ ;_-@_ "
Case "GPD"
clmSh.PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
clmSh.NumberFormat = "_-[$£-809]* #,##0.00_ ;_-[$£-809]* -#,##0.00 ;_-[$£-809]* ""-""??_ ;_-@_ "
End Select
End If
Next
Application.CutCopyMode = False
Cells(1, 1).Select
End Sub