Na, da hatten wir dich ja ziemlich miss- ...
18.11.2014 16:15:42
Luc:-?
…verstanden, Andreas;
da es ja nur um das zeichengerechte Positionieren in einem Formular geht, muss ja nichts formatiert, sondern nur erzeugt wdn. Also reichen die angegebenen Fml-Lösungen (speziell von Werner mit Ergebniszellen) oder Rudis DirektLösung am Original.
Falls eine kürzere Fml-Lösung unter Einsatz auch anderweitig nutzbarer universeller UDFs interessant wäre, könnte die zB so aussehen: =VJoin(Sprite(A1;"");WIEDERHOLEN(" ";5))
Hier könnte natürlich auch gleich 5 Leerzeichen statt WIEDERHOLEN(" ";5) und die universellere UDF MxJoin (im Archiv zu finden) verwendet wdn. Ansonsten folgende PgmCodes in ein allgemeines Modul (Einfügen - Modul) des (VBA-)Projekts kopieren:
Rem Verbinden aller Elemente eines beliebigen Vektors
' Vs1.0 -LSr -cd:20130904 -1pub:20130905herber -lupd:20130904t
Function VJoin(Bezug, Optional ByVal BindeZ As String = " ")
On Error Resume Next
With WorksheetFunction
If TypeName(Bezug) = "Range" Then
Bezug = .Transpose(.Transpose(Bezug))
End If
If IsError(LBound(Bezug, 2)) Then
VJoin = Join(Bezug, BindeZ)
Else: Bezug = .Transpose(Bezug)
If IsError(LBound(Bezug, 2)) Then
VJoin = Join(Bezug, BindeZ)
Else: VJoin = CVErr(xlErrRef)
End If
End If
End With
End Function
Rem F18: udF erzeugt aus TextBezug(sVektor) m.def TrennZch 1 ZeilVekt(bzw 1 Matrix)Feld
' Auf volle MxFmlFähigk b.diff QuellTxt u.Verarbeit v.MxKonstt in Textform erweiterte
' VarKomb d.xxlFktt Splint u.TransFor aus xlAddIn FXsubset v.Autor LSr[CyWorXxl.FXss]
' Vs2.3 -Autor: LSr -CDate: 20070427 -1Pub: 20070428 herber.de (1.2) -lUpD: 20110810n
Function Sprite(ByVal Bezug, Optional ByVal TrennZ As String = " ")
Const orMxKlTr As String = "{ , ; }"
Dim s As Long, z As Long, i As Integer, n As Integer, arvErg(), ZwErg As Variant, _
DzTr As String, LiTr As String, MxKl(1) As String, MxTr(1) As String, arvBez
On Error Resume Next
With Application
DzTr = .International(xlDecimalSeparator)
LiTr = .International(xlListSeparator)
MxKl(0) = .International(xlLeftBrace)
MxKl(1) = .International(xlRightBrace)
MxTr(0) = .International(xlColumnSeparator)
MxTr(1) = .International(xlRowSeparator)
End With
If IsArray(Bezug) Then
arvBez = Bezug
If TypeName(arvBez) = "Range" Then
ReDim arvErg(arvBez.Cells.Count - 1, 0)
ElseIf IsError(LBound(arvBez, 2)) Then
ReDim arvErg(UBound(arvBez) - LBound(arvBez), 0)
ElseIf UBound(arvBez, 2) = LBound(arvBez, 2) Then
arvBez = WorksheetFunction.Transpose(arvBez)
If IsError(LBound(arvBez, 2)) Then
ReDim arvErg(UBound(arvBez) - LBound(arvBez), 0)
Else: Sprite = CVErr(xlErrRef): Exit Function
End If
Else: ReDim arvErg(UBound(arvBez) - LBound(arvBez), 0)
End If
For Each Bezug In arvBez
GoSub eb: ZwErg = Sprite
If UBound(ZwErg) > UBound(arvErg, 2) Then _
ReDim Preserve arvErg(UBound(arvErg, 1), UBound(ZwErg))
For s = 0 To UBound(ZwErg)
arvErg(z, s) = ZwErg(s)
Next s
z = z + 1
Next Bezug
Sprite = arvErg: Exit Function
End If
eb: If Left(Bezug, 1) = MxKl(0) And Right(Bezug, 1) = MxKl(1) Then
If TrennZ = "" Then
If Mid(Bezug, 2, 1) = """" Then
i = 3: n = 2: TrennZ = """" & MxTr(0) & """"
ElseIf IsNumeric(Mid(Bezug, 2, Len(Bezug) - 2)) Then
i = 2: n = 1: TrennZ = MxTr(0)
Else: Bezug = MxKl(0) & """" & Mid(Bezug, 2, Len(Bezug) - 2) & _
"""" & MxKl(1): i = 3: n = 2
TrennZ = """" & MxTr(0) & """"
End If
While i
Gruß, Luc :-?
Besser informiert mit …