Spalten formatieren VBA
08.11.2013 10:03:49
Peter
Ich möchte über VBA bei diversen, teilw. nicht zusammenhängenden Spalten je nach Auswahl im Dropdownmenü die Währung umformatieren. Dazu habe ich folgenden Code geschrieben:
Private Sub waehrung_Change()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ber, ber2, ber3, ber4, ber5, ber6, ber7, Waehrung, cell As Range
Dim ende As Long
With Worksheets("Kalkulation")
ende = .Cells(Rows.Count, 1).End(xlUp).Row
End With
Set Waehrung = Worksheets("Eingabe").Range("d2")
Set ber = Worksheets("Kalkulation").Range("p6:p" & ende)
Set ber2 = Worksheets("Kalkulation").Range("r6:r" & ende)
Set ber3 = Worksheets("Kalkulation").Range("t6:y" & ende)
Set ber4 = Worksheets("Kalkulation").Range("ab6:ag" & ende)
Set ber5 = Worksheets("Kalkulation").Range("ax6:bd" & ende)
Set ber6 = Worksheets("Kalkulation").Range("bg6:bg" & ende)
Set ber7 = Worksheets("Kalkulation").Range("bo6:bo" & ende)
Set alleber = Union(ber, ber2, ber3, ber4, ber5, ber6, ber7)
For Each cell In alleber
If Waehrung.Value = "CHF" Then
cell.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""?_);_(@_)"
End If
If Waehrung.Value = "EUR" Then
cell.NumberFormat = "#,##0.00 [$-407];-#,##0.00 [$-407]"
End If
Next
MsgBox "Währung ist umgestellt!"
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Für Eure Hilfe danke ich Euch bestens.
Lieber Gruss
Peter