如何连续连接单元格直到第一个空白单元格

Question

我目前是第一次深入研究代码/VBA 编码。我有一个文件，我将其转储到当前我正在手动组织和推出的工作表中。当放入工作表时，它会在单元格之间划定界限。前 2-4 个单元格始终是名称的一部分。每次我在给定的一天得到它并转储到工作表中时，这个转储文件都会有不同的行和列长度。例如，一天可能是二十行，一天可能是三十。

这是数据外观的粗略说明，但我的代码可能与下面的示例不匹配 - 我只是想提供一个视觉效果：

所以，我想编写从 A1 开始的代码，并将其后面的单元格连接起来，直到它遇到该行中的空白单元格。然后它将连接的数据放入单元格 A1 并删除它从中提取名称片段的值并将所有数据滑动到左侧。之后，它在下一行继续相同的操作，直到遇到最后一行。如图所示，我不希望空白单元格之后的任何数据受到影响。

这是我第一次编程，所以当您提供帮助时，请您解释一下您的代码以便我学习这些概念吗？这是我认为到目前为止可行的方法......我只是坚持如何进行连接。

我目前拥有的代码：

Sub DN_ERROR_ORGANIZER()
  Dim row As Integer
  NumRows = Range("A1", Range("A1").End(xldown)).Rows.Count
  Range("A1").Select
  For row = 1 To NumRows
      Do Until IsEmpty(ActiveCell)
          ' Code to concatenate
          ActiveCell.Offset(1, 0).Select
      Loop
      ActiveCell.Offset(1, 0).Select
  Next
End sub

Answer 1

这是查看问题的另一种方法：假设您的表格在 Sheet2 上，结果反映在 Sheet1 上。

Sub PutInOrder()
  filledcells = 0
  '''lastrow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row

  For i = 1 To 100
     If Sheet2.Cells(i, 1) = "" Then Exit For 
     For a = 1 To 4
        If Sheet2.Cells(i, a) = "" Then Exit For
          If Sheet2.Cells(i, a) <> "" Then
             filledcells = filledcells + 1
        End If
    Next

Select Case filledcells
    Case Is = 2

        Sheet1.Cells(i, 1) = Sheet2.Cells(i, 1) + ", " + Sheet2.Cells(i, 2)
        Sheet1.Cells(i, 3) = Sheet2.Cells(i, 4)
        Sheet1.Cells(i, 4) = Sheet2.Cells(i, 5)
        Sheet1.Cells(i, 5) = Sheet2.Cells(i, 6)
        Sheet1.Cells(i, 6) = Sheet2.Cells(i, 7)


    Case Is = 3

        Sheet1.Cells(i, 1) = Sheet2.Cells(i, 1) + ", " + Sheet2.Cells(i, 2) + " " + Sheet2.Cells(i, 3)
        Sheet1.Cells(i, 3) = Sheet2.Cells(i, 5)
        Sheet1.Cells(i, 4) = Sheet2.Cells(i, 6)
        Sheet1.Cells(i, 5) = Sheet2.Cells(i, 7)
        Sheet1.Cells(i, 6) = Sheet2.Cells(i, 8)


    Case Is = 4

        Sheet1.Cells(i, 1) = Sheet2.Cells(i, 1) + ", " + Sheet2.Cells(i, 2) + " " + Sheet2.Cells(i, 3) + " " + Sheet2.Cells(i, 4)
        Sheet1.Cells(i, 3) = Sheet2.Cells(i, 6)
        Sheet1.Cells(i, 4) = Sheet2.Cells(i, 7)
        Sheet1.Cells(i, 5) = Sheet2.Cells(i, 8)
        Sheet1.Cells(i, 6) = Sheet2.Cells(i, 9)

   End Select
   filledcells = 0
 Next
 End Sub

Answer 2

你能试试这个，让我知道你的情况吗？根据您的精确布局，它可能需要一些调整。我的方法略有不同。

 Sub x()

Dim n As Long, r1 As Range, r2 As Range, v

For n = 1 To Range("A" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    Set r1 = Cells(n, 1).EntireRow.SpecialCells(xlCellTypeConstants).Areas(1)
    Set r2 = Cells(n, 1).EntireRow.SpecialCells(xlCellTypeConstants).Areas(2)
    If Not r1 Is Nothing And Not r2 Is Nothing Then
        v = Join(Application.Transpose(Application.Transpose(r1)), ", ")
        Cells(n, 1) = WorksheetFunction.Proper(v)
        Cells(n, 2).Resize(, r1.Count).Clear
        r2.Cut Cells(n, 3)
    End If
Next n

End Sub