Clever-Excel-Forum

Hallo Community,

zunächst euch allen ein frohes neues Jahr! :)
Ich habe hier mehrere Arbeitsblätter und müsste von Fall zu Fall die Zellen in denen € enthalten sind beaufschlagen.
Ist es möglich, ein Makro zu schreiben der mir die Zellen A1:J67 durchsucht und alle Zellen in denen ein € oder als Buchhaltung formatiert sind beaufschlagt?
Könnte mir hierzu jemand helfen? Blush

Besten Dank im Voraus und viele Grüße Steve

Hallo,

Code:
Public Sub Aufschlag()

Dim raZelle As Range

With Worksheets("Tabelle1")

    For Each raZelle In .Range("A1:J64")

        Select Case raZelle.NumberFormat

            Case "$#,##0.00_);($#,##0.00)", "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"

                raZelle = raZelle + (raZelle * 10 / 100)

            Case Else

        End Select

    Next raZelle

End With

End Sub

Gruß Werner

wow! Danke das funktioniert. Mein Ansatz mit .Find("€", lookat:=xlPart, MatchCase:=True) hat nicht tadellos geklappt :(

Hallo,

nach einigen Versuchen und das Einbetten in meine Exceldatei hat die Lösung von Werner nicht mehr funktioniert.
Ich habe im www eine alternative gefunden und diese etwas umgeschrieben. Das komische daran ist, manchmal funktioniert es, manchmal nicht. Ich kann es leider nicht reproduzieren. Eventuell liegt es an einer Excelversion? Ich bin etwas Ratlos.

Ich möchte gerne weiterhin alle Zellen in einem Activesheet nach € suchen und diesen Zelleninhalt um X% reduzieren.
Hier mein Code:

Private Sub CommandButton1_Click()

Dim rngBer As Range
Dim rngFund As Range
Dim strAdr As String

prozwert = InputBox("Prozentwert eingeben")
prozwert = 1 - (prozwert / 100)

Set rngBer = ActiveSheet.UsedRange
Set rngFund = rngBer.Find("€", lookat:=xlPart, MatchCase:=True)
With rngFund
.Value = .Value * prozwert
'.Value = Application.WorksheetFunction.RoundUp(.Value * prozwert, 0)
strAdr = .Address
End With

Do
Set rngFund = rngBer.FindNext(rngFund)
If rngFund.Address = strAdr Then Exit Sub
With rngFund
.Value = .Value * prozwert
'.Value = Application.WorksheetFunction.RoundUp(.Value * prozwert, 0)
End With
Loop
End Sub

Und hier die Datei:

[attachment=36349]

Funktioniert das bei jemanden?

Vielen Dank im Voraus.

Grüße Steve

Hallo Steve,

Set rngFund = rngBer.Find(What:="€", LookIn:=xlValues, lookat:=xlPart, MatchCase:=True)

Gruß Uwe

Besten Dank Uwe! Es funktioniert! :) :)

Moin!
Zu MatchCase:=True
Gibt es auch ein kleines €?

*DuckUndWeg*

Gruß Ralf

tyr0n

Werner.M

tyr0n

tyr0n

Kuwer

tyr0n

RPP63

tyr0n