Verkettung nonblank Wert VBA

Question

Ich muss Zeilen in 2 Spalten nur für eindeutige ID verketten. Jeeped half mir mit folgendem Code

Option Explicit 
Sub qwewreq() 
    Dim rw As Long 
    With Worksheets("Sheet3") 
     For rw = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 To 2 Step -1 
      If .Cells(rw, "A").Value2 = .Cells(rw + 1, "A").Value2 Then 
       .Cells(rw, "B") = .Cells(rw, "B").Value2 &Chr(10) & .Cells(rw + 1, "B").Value2 
       .Cells(rw, "C") = .Cells(rw, "C").Value2 &Chr(10) & .Cells(rw + 1, "C").Value2 
       .Rows(rw + 1).EntireRow.Delete 
      End If 
     Next rw 
    End With 
End Sub 

ich versuche, ein Symbol nach jedem nicht leeren Wert hinzuzufügen. Der obige Code fügt nach jeder Zelle ein Symbol hinzu. Ist es irgendwie möglich, diesen Code zu modifizieren, so dass Chr (10) erst nach nichtblank hinzugefügt werden könnte?

Danke! Das hat geholfen !!

Answer 1

Wenn Spalte B leer ist, dann Zeilenumbruch nicht enthalten. Sie können dies ein paar Möglichkeiten. Ein Weg ist ein Inline-IF.

Option Explicit 
Sub qwewreq() 
    Dim rw As Long 
    With Worksheets("Sheet3") 
     For rw = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 To 2 Step -1 
      If .Cells(rw, "A").Value2 = .Cells(rw + 1, "A").Value2 Then 
       .Cells(rw, "B") = .Cells(rw, "B").Value2 & iif(len(.Cells(rw, "B").Value2)>0,Chr(10),"") & .Cells(rw + 1, "B").Value2 
       .Cells(rw, "C") = .Cells(rw, "C").Value2 & iif(len(.Cells(rw, "C").Value2)>0,Chr(10),"") & .Cells(rw + 1, "C").Value2 
       .Rows(rw + 1).EntireRow.Delete 
      End If 
     Next rw 
    End With 
End Sub 

Ein andere Möglichkeit, ein wenig länger, aber leichter zu lesen:

Option Explicit 
Sub qwewreq() 
    Dim rw As Long 
    With Worksheets("Sheet3") 
     For rw = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 To 2 Step -1 
      If .Cells(rw, "A").Value2 = .Cells(rw + 1, "A").Value2 Then 
       if len(.Cells(rw, "B").Value2) > 0 then 
        .Cells(rw, "B") = .Cells(rw, "B").Value2 &Chr(10) & .Cells(rw + 1, "B").Value2 
       else 
        .Cells(rw, "B") = .Cells(rw + 1, "B").Value2 
       end if 
       if len(.Cells(rw, "C").Value2) > 0 then 
        .Cells(rw, "C") = .Cells(rw, "C").Value2 &Chr(10) & .Cells(rw + 1, "C").Value2 
       else  
        .Cells(rw, "C") = .Cells(rw + 1, "C").Value2 
       end if 
       .Rows(rw + 1).EntireRow.Delete 
      End If 
     Next rw 
    End With 
End Sub 

Answer 2

Ihre Frage ist nicht sehr klar. Hoffentlich verstand ich es genug, um zu antworten:

Option Explicit 
Sub qwewreq() 
Dim rw As Long 
With Worksheets("Sheet1") 
    For rw = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 To 2 Step -1 
     If .Cells(rw, "A").Value2 = .Cells(rw + 1, "A").Value2 Then 
      If .Cells(rw + 1, "B").Value2 <> "" Then 
      .Cells(rw, "B") = .Cells(rw, "B").Value2 & Chr(10) & .Cells(rw + 1, "B").Value2 
      Else 
      .Cells(rw, "B") = .Cells(rw, "B").Value2 
      End If 
      If .Cells(rw + 1, "C").Value2 <> "" Then 
      .Cells(rw, "C") = .Cells(rw, "C").Value2 & Chr(10) & .Cells(rw + 1, "C").Value2 
      Else 
      .Cells(rw, "C") = .Cells(rw, "C").Value2 & Chr(10) 
      End If 
      .Rows(rw + 1).EntireRow.Delete 
     End If 
    Next rw 
End With 
End Sub