VBA Activen Bereich für resize in Range wählen

Bild

Betrifft: VBA Activen Bereich für resize in Range wählen
von: willoserus
Geschrieben am: 19.08.2015 09:00:54

Hallo,
ich habe per google ein fast passendes Makro gefunden, was meinen Wünschen entspricht. Allerdings werden in Zeile 4 beim resize Befehl statisch nur die ersten vier Zellen verkettet.
Ich habe einen festen Bereich in der Zeile von J-AC, in dem verschieden viele Zellen (mal nur eine bis hin zu 20) mit Werten sein können, und nur die möchte ich über ein Komma verketten. Mit anderen Worten: Bei festen Werten habe ich sonst am Ende eine Menge überflüssiger Kommata ;-)
Für Hilfe wäre ich dankbar.
Das ist das Makro
hier gefunden: http://www.office-loesung.de/ftopic577603_0_0_asc.php

Sub test() 
Dim Zelle As Range 
For Each Zelle In Range("H6:H" & Cells(Rows.Count, 10).End(xlUp).Row) 
    Call VerkettenMitFormat(Zelle, Zelle.Offset(0, 2).Resize(1, 4), ",") 
Next 
End 

Sub 

Sub VerkettenMitFormat(Ziel As Range, Quelle As Range, Optional TrKZ As String = "") 
Dim Zelle As Range 
Dim txt As String 
Dim Pos1 As Long 
Dim LängeTRKZ As Long 
Dim Länge As Long 
LängeTRKZ = Len(TrKZ) 
For Each Zelle In Quelle 
    txt = txt & TrKZ & Zelle.Text 
Next 
Ziel.Value = Mid(txt, LängeTRKZ + 1) 
Pos1 = 1 
For Each Zelle In Quelle 
    With Ziel.Characters(Start:=Pos1, Length:=Len(Zelle.Text)) 
        .Font.Name = Zelle.Font.Name 
        .Font.Size = Zelle.Font.Size 
        .Font.FontStyle = Zelle.Font.FontStyle 
        .Font.Italic = Zelle.Font.Italic 
        .Font.Color = Zelle.Font.Color 
        .Font.Strikethrough = Zelle.Font.Strikethrough 
        .Font.Subscript = Zelle.Font.Subscript 
        .Font.Superscript = Zelle.Font.Superscript 
        .Font.Underline = Zelle.Font.Underline 
    End With 
    Pos1 = Pos1 + Len(Zelle.Text) + LängeTRKZ 
Next 
End Sub

Bild

Betrifft: So?
von: Michael
Geschrieben am: 19.08.2015 14:28:20
Hi willoserus,
versuch's mal damit:

Sub test()
Dim Zelle As Range
Dim zeilen As Long
zeilen = Cells(Rows.Count, 10).End(xlUp).Row ' das ist Spalte J
For Each Zelle In Range("H6:H" & zeilen)
    Call VerkettenMitFormat(Zelle, Zelle.Offset(0, 2).Resize(1, 8), ",")
Next
End Sub
Sub VerkettenMitFormat(Ziel As Range, Quelle As Range, Optional TrKZ As String = "")
Dim Zelle As Range
Dim txt As String
Dim Pos1 As Long
Dim LängeTRKZ As Long
Dim Länge As Long
LängeTRKZ = Len(TrKZ)
For Each Zelle In Quelle
  If Zelle.Text <> "" Then
    txt = txt & TrKZ & Zelle.Text
  End If
Next
Ziel.Value = Mid(txt, LängeTRKZ + 1)
Pos1 = 1
For Each Zelle In Quelle
  If Zelle.Text <> "" Then
    With Ziel.Characters(Start:=Pos1, Length:=Len(Zelle.Text))
        .Font.Name = Zelle.Font.Name
        .Font.Size = Zelle.Font.Size
        .Font.FontStyle = Zelle.Font.FontStyle
        .Font.Italic = Zelle.Font.Italic
        .Font.Color = Zelle.Font.Color
        .Font.Strikethrough = Zelle.Font.Strikethrough
        .Font.Subscript = Zelle.Font.Subscript
        .Font.Superscript = Zelle.Font.Superscript
        .Font.Underline = Zelle.Font.Underline
    End With
    Pos1 = Pos1 + Len(Zelle.Text) + LängeTRKZ
  End If
Next
End Sub

So werden die Aktionen innerhalb der For-Schleifen nur dann ausgeführt, wenn die Zellen einen Inhalt haben.
Gruß,
Michael

Bild

Betrifft: AW: So?
von: willoserus
Geschrieben am: 19.08.2015 18:05:42
Danke Michael,
funktioniert!!

Bild

Betrifft: freut mich, danke für die Rückmeldung owT
von: Michael
Geschrieben am: 19.08.2015 20:04:04


 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA Activen Bereich für resize in Range wählen"