Объединить две колонки и пропустить пустые ячейки

Question

В моей текущей электронной таблице есть два столбца данных, которые я хотел бы объединить.В своем предоставленном коде я создаю столбец справа от столбцов, которые я хотел бы объединить, а затем использую цикл FOR, чтобы объединить каждое значение со знаком «,» между значениями.Я хотел бы настроить код так, чтобы пропустить ячейки / строки без значений, потому что теперь я получаю "," в моем комбинированном столбце, если два начальных столбца не имеют значений.

Public Sub MergeLatLong()

Dim LastRow As Long

Worksheets("Raw_Data").Activate
Columns("AT:AT").Select

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

LastRow = Range("AR" & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow
    Cells(i, 46) = Cells(i, 44) & ", " & Cells(i, 45)
    Next i

End Sub 

Answer 1

Вот код, который я в итоге использовал, смесь ответов выше.Я создаю некоторый дополнительный код для поиска столбцов с широтой и долготой. Таким образом, если столбцы будут каким-то образом переставлены, программа все равно будет искать правильные столбцы для значений.

Sub concatenateLatLong()

Dim WS As Worksheet
Dim lastRow As Long
Dim longName As String
Dim longColumn As Long
Dim latName As String
Dim latColumn As Long
Dim latValue As String
Dim longValue As String
Dim i As Long

Set WS = Worksheets("Data")

With WS

    lastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False).Row

    'MsgBox "The last row with entered data is " & lastRow

    'Find Longitude column
    longName = "LONGITUDE"

    longColumn = .Rows(1).Find(What:=longName, LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column

    'MsgBox "The " & longName & " header is found in column " & longColumn

    'Insert a row to the right of the longitude column
    .Columns(longColumn + 1).Insert Shift:=xlToLeft, CopyOrigin:=xlFormatFromLeft

    'Give new column header "LAT, LONG"
    .Cells(1, longColumn + 1).Value = "LAT, LONG"

    'Find Latitude column
    latName = "LATITUDE"

    latColumn = .Rows(1).Find(What:=latName, LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column

    'MsgBox "The " & latName & " header is found in column " & latColumn

    'Combine latitude and longitude
    For i = 2 To lastRow

        latValue = Trim(.Cells(i, latColumn).Value)
        longValue = Trim(.Cells(i, longColumn).Value)

        If Len(longValue) Then longValue = ", " & longValue
        If Len(latValue) And Len(longValue) > 0 Then latValue = latValue & longValue

        .Cells(i, longColumn + 1).Value = latValue

        Next i

End With

End Sub

Answer 2

2 столбца 2 One

Версия с быстрым массивом

Sub MergeLatLong() ' Array Version

    Dim vnt1 As Variant   ' 1st Array
    Dim vnt2 As Variant   ' 2nd Array
    Dim vntR As Variant   ' Result Array
    Dim NoR As Long       ' Number of Rows
    Dim i As Long         ' Row Counter
    Dim str1 As String    ' 1st String
    Dim str2 As String    ' 2nd String
    Dim strR As String    ' Result String

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    ' Handle possible error.
    On Error GoTo ErrorHandler

    With ThisWorkbook.Worksheets("Raw_Data")
        ' Insert column ("AT") to the right of column ("AS").
        .Columns("AT").Insert xlToRight, xlFormatFromLeftOrAbove
        ' Calculate Number of Rows (Last Used Row - First Row + 1).
        NoR = .Cells(.Rows.Count, "AR").End(xlUp).Row - 2 + 1
        ' Copy values of column "AR" to 1st Array.
        vnt1 = .Columns("AR").Cells(2).Resize(NoR)
        ' Copy values of column "AS" to 2nd Array.
        vnt2 = .Columns("AS").Cells(2).Resize(NoR)
    End With

    ' Resize Result Array to size of 1st Array (or 2nd Array).
    ReDim vntR(1 To UBound(vnt1), 1 To 1) As String
    ' Remarks: All arrays are of the same size.

    ' Loop through rows of arrays.
    For i = 1 To NoR
        ' Write current value in 1st array to 1st String.
        str1 = vnt1(i, 1)
        ' Write current value in 2nd array to 2nd String.
        str2 = vnt2(i, 1)
        ' Check if 1st String is not empty ("").
        If str1 <> "" Then  ' 1st String is not empty.
            ' Check if 2nd String is not empty ("").
            If str2 <> "" Then  ' 2nd String is not empty.
                ' Concatenate.
                strR = str1 & ", " & str2
              Else              ' 2nd String is empty.
                strR = str1
            End If
          Else              ' 1st String is empty.
            If str2 <> "" Then  ' 2nd String is not empty.
                strR = str2
              Else              ' 2nd String is empty.
                strR = ""
            End If
        End If
        ' Write Result String to current row of Result Array.
        vntR(i, 1) = strR
    Next

    With ThisWorkbook.Worksheets("Raw_Data").Columns("AT")
        ' Copy Result Array to Result Range.
        .Cells(2).Resize(NoR) = vntR
        ' Adjust the width of Result Column.
        .AutoFit
'        ' Apply some additional formatting to Result Range.
'        With .Cells(2).Resize(NoR)
'            ' e.g.
'            .Font.Bold = True
'        End With
    End With

ProcedureExit:
    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:
    MsgBox "An unexpected error has occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbInformation, "Error"
    GoTo ProcedureExit

End Sub

Версия с медленным диапазоном

Sub MergeLatLongRange() ' Range Version

    Dim LastRow As Long   ' Last Row Number
    Dim i As Long         ' Row Counter
    Dim str1 As String    ' 1st String
    Dim str2 As String    ' 2nd String
    Dim strR As String    ' Result String

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    ' Handle possible error.
    On Error GoTo ErrorHandler

    With ThisWorkbook.Worksheets("Raw_Data")
        ' Insert column ("AT") to the right of column ("AS").
        .Columns("AT").Insert xlToRight, xlFormatFromLeftOrAbove
        ' Calculate Last Used Row using 1st column "AR".
        LastRow = .Cells(.Rows.Count, "AR").End(xlUp).Row
        ' Loop through rows in columns.
        For i = 2 To LastRow
            ' Write value of cell at current row in column "AR" to 1st String.
            str1 = .Cells(i, "AR")
            ' Write value of cell at current row in column "AS" to 2nd String.
            str2 = .Cells(i, "AS")
            ' Check if 1st String is not empty ("").
            If str1 <> "" Then  ' 1st String is not empty.
                ' Check if 2nd String is not empty ("").
                If str2 <> "" Then  ' 2nd String is not empty.
                    ' Concatenate.
                    strR = str1 & ", " & str2
                  Else              ' 2nd String is empty.
                    strR = str1
                End If
              Else              ' 1st String is empty.
                If str2 <> "" Then  ' 2nd String is not empty.
                    strR = str2
                  Else              ' 2nd String is empty.
                    strR = ""
                End If
            End If
            ' Write Result String to cell at current row in column "AT".
            Cells(i, "AT") = strR
        Next
        ' Adjust the width of column "AT".
        .Columns("AT").AutoFit
    End With

ProcedureExit:
    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:
    MsgBox "An unexpected error has occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbInformation, "Error"
    GoTo ProcedureExit

End Sub

Answer 3

Код ниже должен делать то, что вы собираетесь.Если оба значения будут пропущены, будет введен пробел: только первое (без запятой), если второе отсутствует, и только второе (с запятой), если первое отсутствует.Вы можете настроить эту часть в соответствии с вашими потребностями.

Public Sub MergeLatLong()

    Dim Ws As Worksheet
    Dim LastRow As Long
    Dim Combo As String, Tmp As String
    Dim R As Long

    ' No need to Activate or Select anything!
    Set Ws = Worksheets("Raw_Data")
    With Ws
        .Columns(46).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

        LastRow = .Cells(Rows.Count, "AR").End(xlUp).Row
        For R = 2 To LastRow
            ' if you mean the 'Value' it's better to specify the 'Value' property
            Combo = Trim(.Cells(R, 44).Value)    ' treat Space as blank
            Tmp = Trim(.Cells(R, 45).Value)      ' treat Space as blank

            If Len(Tmp) Then Tmp = ", " & Tmp
            If Len(Combo) And Len(Tmp) > 0 Then Combo = Combo & Tmp

            Cells(R, 46).Value = Combo
        Next R
    End With
End Sub

Как и @Dude Scott, я также чувствовал, что функция рабочего листа может быть более подходящей.VBA может иметь некоторые преимущества, если это очень часто повторяющаяся задача.

Если количество записей велико, добавьте Application.ScreenUpdating = False перед циклом For .. Next и сбросьте ScreenUpdating в True в конце процедуры.,Это значительно улучшит скорость.

Answer 4

Вы можете циклически проходить по столбцу AR, а не только к пустым ячейкам, и проверять содержимое столбца AS, чтобы правильно добавить запятую

, кроме того, избегайте активировать / выбирать шаблон и используйте прямую и явную ссылку на диапазоны:

Public Sub MergeLatLong()

    Dim cell As Range

    With Worksheets("Raw_Data") ' reference wanted worksheet
        .Columns("AT:AT").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

        For Each cell In .Range("AR2", .Cells(.Rows.Count, "AR").End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced sheet column AR cells with some "constant" values
            If IsEmpty(cell.Offset(, 1)) Then
                cell.Offset(, 2) = cell.Value
            Else
                cell.Offset(, 2) = cell.Value & ", " & cell.Offset(, 1)
            End If
        Next
    End With
End Sub

Answer 5

Вам нужно использовать VBA?Я бы порекомендовал использовать формулу TEXTJOIN (если у вас Excel 2016).Предполагая ваши ячейки в столбцах AR и AS и формулу в AT.

Параметры для формулы: =TEXTJOIN(delimiter,ingnore_blanks,range)

Таким образом, приведенная ниже формула в AT1 будет возвращать объединение двух столбцов для каждой строки с запятой в качестве разделителя, если в обоих содержится содержимое.колонны.

=TEXTJOIN(“,”,TRUE,AR1:AS1) 

Если вы используете версию меньше 2016 года. Вы можете просто использовать следующее

=AR1&IF(ISBLANK(AS1),””,”, AS1”)

Любое из них можно перетащить вниз, и у вас не будет лишних запятых.в любых строках с пробелом в столбце AS.