非空拼接

• 将J更换为I，以根据需要进行更换。

Option Explicit

Sub AppendUnits()

    Const WS_NAME As String = "Export"
    Const CAL_FIRST_CELL As String = "I2"
    Const UNIT_COLUMN As String = "H"
    Const DST_COLUMN As String = "J" ' Result
    Const DELIMITER As String = " "
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Sheets(WS_NAME)
    
    Dim crg As Range, rCount As Long
    
    With ws.Range(CAL_FIRST_CELL)
        Dim lCell As Range: Set lCell = .Resize(.Worksheet.Rows.Count _
            - .Row + 1).Find("*", , xlFormulas, , , xlPrevious)
        If Not lCell Is Nothing Then
            rCount = lCell.Row - .Row + 1
            Set crg = .Resize(rCount)
        End If
    End With
    
    If crg Is Nothing Then
        MsgBox "No data found.", vbCritical
        Exit Sub
    End If
    
    Dim urg As Range: Set urg = crg.EntireRow.Columns(UNIT_COLUMN)
    
    Dim cData(), uData()
    
    If rCount = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
        ReDim uData(1 To 1, 1 To 1): uData(1, 1) = urg.Value
    Else
        cData = crg.Value
        uData = urg.Value
    End If
    
    Dim r As Long, rStr As String
    
    For r = 1 To rCount
        rStr = CStr(cData(r, 1))
        If Len(rStr) > 0 Then
            cData(r, 1) = rStr & DELIMITER & CStr(uData(r, 1))
        End If
    Next r
    
    Dim drg As Range: Set drg = crg.EntireRow.Columns(DST_COLUMN)
    
    drg.Value = cData
    
    MsgBox "Units appended.", vbInformation
    
End Sub