VBA- Einsparungen mit Union( möglich?

31/08/2014 - 17:44 von Hans Alborg | Report spam
Hallo,

<Excel 2007>

Ich habe sehr viel Code in meiner Mappe wie den:
'--
Set Kontakte_s = Union(Cells(12, mynr + 7), _
Cells(12, mynr + 12))
Set Kont_Anz(1) = Cells(12, mynr + 7)
Set Kont_Anz(2) = Cells(12, mynr + 12)
' ( das geht bis zu 8 Stck.! )
Call Schließer_senkrecht
Call Kontaktnamen_Anzug
' --
' die Unterroutinen dazu:
' --
Sub Schließer_senkrecht()
Kontakte_s.Borders(xlEdgeTop).LineStyle = xlNone
End Sub
' --
Sub Kontaktnamen_Anzug()
For j = 1 To 8
With Kont_Anz(j)
If Kont_Anz(j) Is Nothing Then Exit Sub
.Value = Left(Kont_Anz(j).Value, Len(Kont_Anz(j).Value) - 1)
& "á"
.Characters(Start:=Len(Kont_Anz(j).Value),
Length:=1).Font.Name = "Wingdings"
End With
Set Kont_Anz(j) = Nothing
Next j
End Sub
' --
Das sind in meiner Simulation Schaltkontakte (grafisch mit Rahmenteilen
dargestellt) und deren Bezeichnungen.
Das ist immer so, daß beide Zelladressen gleich sind, wie oben gezeigt.
Es gibt aber viele dieser Vorgànge mit bis zu 8 Zellen irgendwo auf dem
Blatt!

Leider gelingt es mir nicht, das Union -Feld für die Namen zu benutzen, weil
die in jeder Zelle verschieden sein können.
Wie in der 2. Unterroutine zu sehen ist, àndere ich nur das letzte Zeichen
eines verschieden langen Strings (und dessen Font).
Dieses Zeichen ist ein Pfeil nach oben (woanders wird es in einen Pfeil nach
unten geàndert).

Gibt es eine Möglichkeit, beide Änderungen doch mit 1x Union(Cells...)
anzusprechen?

TIA,

Hans
 

Lesen sie die antworten

#1 Claus Busch
31/08/2014 - 18:21 | Warnen spam
Hallo Hans,

Am Sun, 31 Aug 2014 17:44:50 +0200 schrieb Hans Alborg:


Gibt es eine Möglichkeit, beide Änderungen doch mit 1x Union(Cells...)
anzusprechen?



probiere mal folgenden Code. Du musst zuerst "Test" laufen lassen, damit
"Kontakte_s" initialisiert ist:

Option Explicit
Public Kontakte_s As Range

Sub Test()
Dim strNr As String
Dim arrNr As Variant, Kont_Anz() As Variant
Dim i As Long, myNr As Long

strNr = "7,12,17,22,27"
arrNr = Split(strNr, ",")
myNr = 5

For i = LBound(arrNr) To UBound(arrNr)
ReDim Preserve Kont_Anz(UBound(arrNr))
Kont_Anz(i) = Cells(12, myNr + arrNr(i))
Next

For i = LBound(arrNr) To UBound(arrNr)
If Kontakte_s Is Nothing Then
Set Kontakte_s = Cells(12, myNr + arrNr(i))
Else
Set Kontakte_s = Union(Kontakte_s, Cells(12, myNr + arrNr(i)))
End If
Next

End Sub

Sub Kontaktnamen_Anzug()
Dim rngC As Range

For Each rngC In Kontakte_s
If rngC Is Nothing Then Exit Sub
With rngC
.Value = Left(rngC, Len(rngC.Text) - 1) & "á"
.Characters(Start:=Len(rngC), _
Length:=1).Font.Name = "Wingdings"
End With
Next
End Sub


Mit freundlichen Grüßen
Claus
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Ähnliche fragen