Makro na převod jednotek

[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.

[Reklama]

[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.

[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é.

[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