Question

我需要仅为唯一ID连接2列中的行。 Jeeped用下面的代码帮助了我

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

我尝试在每个非空白值后添加一个符号。以上代码在每个单元格后添加符号。有可能以某种方式修改此代码，以便只能在nonblank之后添加Chr（10）吗？

谢谢！这有助于!!

Answer 1

你的问题不是很清楚。希望我理解它足以回答：

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

Answer 2

如果B列为空白，则不包括换行符。你可以通过几种方式做到这一点。一种方法是内联iif。

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

另一种方式，有点长，但更容易阅读：

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

连接非空值vba

2 个答案: