wenn Bedingung erfüllt, String in Grossbuchst umw.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim arrN, ii As Long If Not HatNichtZiffern(Sh.Name) Then Exit Sub If Target.Count = 1 Then Exit Sub If Target.Row >= 5 And Target.Row

Halllo Erich
Bei diesen benannten Zellen trifft beides zu. Wenn sich beispielsweise Range("ABC") auf C2 (=in Spalte 3) bezieht, ist in dieser Zelle auch eine 3 eingetragen.
Ich habe eine Datei hochgeladen (in welcher dein Code nun enthalten ist). Hier müsste in der Tabelle "0001", wenn ich in den gelben Bereich etwas hineinschreibe, dies in Grossbuchstaben umgewandelt werden (allerdings müsste ich noch eine Einschränkung machen: nur bei der Tabelle "0000" soll - obwohl auch numerisch - nichts passieren.
Die Eingaben im gelben Bereich erfolgen sowohl einzeln als auch mehrere Zellen miteinander.
Wenn ich richtig verstehe, schliesst die Codezeile
If Target.Count = 1 Then Exit Sub
Einzeleinträge aus. Diese sollten jedoch auch umgewandelt werden.
Gäbe es auch die Möglichkeit, anstelle dem Schreiben der Namen in einen Array diese in einer Tabelle, ab Zelle A1 fortlaufend in Spalte A einzutragen?
Vielen Dank für die Hilfe und freundlicher Gruss, Peter
https://www.herber.de/bbs/user/73287.xls

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim arrN, lngN As Long, ii As Long If HatNichtZiffern(Sh.Name) Then Exit Sub ' nur Ziffern If 1 * Sh.Name = 0 Then Exit Sub ' nicht "000" If Target.Count > 1 Then Exit Sub ' nur Einzelzellen If Target.Row >= 5 And Target.Row

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim rngW As Range, rngA As Range, rngC As Range, arrN, lngN As Long, ii As Long If HatNichtZiffern(Sh.Name) Then Exit Sub ' nur Ziffern If 1 * Sh.Name = 0 Then Exit Sub ' nicht "000" With Sheets("DEF") ' Namenliste in "DEF" lngN = .Cells(.Rows.Count, 1).End(xlUp).Row ' Anzahl Namen arrN = .Cells(1, 1).Resize(lngN) ' Namen aus Sp. A End With ' Wirkbereich ermitteln Set rngW = Sh.Cells(5, Range(arrN(1, 1)).Value).Resize(55) For ii = 2 To UBound(arrN) Set rngW = Union(rngW, Sh.Cells(5, Range(arrN(ii, 1)).Value).Resize(55)) Next ii If Intersect(Target, rngW) Is Nothing Then Exit Sub ' geänd. Zellen im Wirkbereich Application.EnableEvents = False For Each rngA In Intersect(Target, rngW).Areas For Each rngC In rngA rngC = UCase$(rngC) Next rngC Next rngA Application.EnableEvents = True End Sub

Hallo Erich
Vielen Dank, ich habe das getestet. Ich habe ein paar kleine Anpassungen gemacht.
A) Der Zeilenbeginn (5) übergebe ich jetzt mit [zeStart] und das Ende (59) mit [zeEnde]
B) Beim Resize muss ich nach meinem Verständnis die Anfangsposition wieder in Abzug bringen und 1 dazuzählen, sonst funktioniert die Umwandlung über den Bereich hinaus.
Jetzt habe ich noch ein Anliegen: Anstelle die Namen der benannten Zellen in der der Tabelle ab A1 einzutragen, möchte ich diese in einem ein-spaltigen Bereich, den ich mit "spUCase" benannt habe eintragen, wobei dieser Bereich am Ende noch ein paar Zeilen hat, wo nichts eingetragen ist.
Ich habe versucht, dies wie folgt zu lösen, jedoch ohne Erfolg:
'' lngN = Application.WorksheetFunction.CountA(Range("spUCase")) - [spUCase].Rows.Count
'' arrN = Range("spUCase").Resize(lngN)
Vielen Dank und Gruss, Peter

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngW As Range, rngA As Range, rngC As Range, arrN, lngN As Long, ii As Long
If HatNichtZiffern(Sh.Name) Then Exit Sub          ' nur Ziffern
If 1 * Sh.Name = 0 Then Exit Sub                   ' nicht "000"
With Sheets("DEF")                        ' Namenliste in "DEF"
lngN = .Cells(.Rows.Count, 1).End(xlUp).Row  ' Anzahl Namen
arrN = .Cells(1, 1).Resize(lngN)             ' Namen aus Sp. A
End With
' Wirkbereich ermitteln
Set rngW = Sh.Cells([zeStart], Range(arrN(1, 1)).Value).Resize([zeEnd] - [zeStart] + 1)
For ii = 2 To UBound(arrN)
Set rngW = Union(rngW, Sh.Cells([zeStart], Range(arrN(ii, 1)).Value).Resize([zeEnd] - [ _
zeStart] + 1))
Next ii
If Intersect(Target, rngW) Is Nothing Then Exit Sub
' geänd. Zellen im Wirkbereich
Application.EnableEvents = False
For Each rngA In Intersect(Target, rngW).Areas
For Each rngC In rngA
rngC = UCase$(rngC)
Next rngC
Next rngA
Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim rngW As Range, rngA As Range, rngC As Range, arrN, lngN As Long Dim lngZ As Long, ii As Long If HatNichtZiffern(Sh.Name) Then Exit Sub ' nur Ziffern If 1 * Sh.Name = 0 Then Exit Sub ' nicht "0...0" With Sheets("DEF") ' Namenliste in "DEF" lngN = Application.WorksheetFunction.CountA(Range("spUCase")) arrN = Range("spUCase").Resize(lngN) End With ' Wirkbereich ermitteln lngN = Range("zeStart") ' 1. Zeile lngZ = Range("zeEnd") - lngN + 1 ' Anz. Zeilen Set rngW = Sh.Cells(lngN, Range(arrN(1, 1))).Resize(lngZ) For ii = 2 To UBound(arrN) Set rngW = Union(rngW, Sh.Cells(lngN, Range(arrN(ii, 1))).Resize(lngZ)) Next ii If Intersect(Target, rngW) Is Nothing Then Exit Sub ' geänd. Zellen im Wirkbereich Application.EnableEvents = False For Each rngA In Intersect(Target, rngW).Areas For Each rngC In rngA rngC = UCase$(rngC) Next rngC Next rngA Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

wenn Bedingung erfüllt, String in Grossbuchst umw.

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

351 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

wenn Bedingung erfüllt, String in Grossbuchst umw.

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

351 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread