Zelleninhalt mit € suchen und mit xx% beaufschlagen

[tyr0n]

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? 

Besten Dank im Voraus und viele Grüße Steve

[Werner.M]

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

[tyr0n]

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

[tyr0n]

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: 


  Alle Zellen mit Euro suchen.xlsm (Größe: 20,28 KB / Downloads: 2)

Funktioniert das bei jemanden?

Vielen Dank im Voraus.

Grüße Steve

[Kuwer]

Hallo Steve,

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

Gruß Uwe

[tyr0n]

Besten Dank Uwe! Es funktioniert! :) :)

[RPP63]

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

*DuckUndWeg*

Gruß Ralf

[tyr0n]