宏来解除空白细胞之间的细胞

Question

我有一张包含所有日期信息的主表。我想根据column C中提到的所选日期将这些信息复制到另一张表格。我可以复制column B商品，但不能column A，因为column A有一些合并的单元格。请查看附件并帮助我获取代码。

到目前为止我的代码如下

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Acell As String
Dim Bcell As String
Dim Ccell As String
Dim cellA As String
Dim cellB As String

i = 1
a = 1
k = 1

For j = 1 To 100
    Acell = "A" & j
    Bcell = "B" & i
    Ccell = "C" & j
    cellB = "B" & k

    celltext = Sheets(1).Range(Ccell)

    If IsEmpty(Sheets(1).Range(Ccell).Value) = True Then
        ' need the code here
        k = k + 1
    ElseIf celltext Like "*all*" Then
        Sheets(1).Range(Bcell).Copy Sheets(2).Range(cellB)
        k = k + 1
    ElseIf celltext Like "*bd4*" Then
        Sheets(1).Range(Bcell).Copy Sheets(2).Range(cellB)
        k = k + 1
    End If

    i = i + 1
Next

结果应该是这样的 result

Answer 1

嗯，我做的是这个

1. 循环合并的单元格以获取作业（合并的单元格在第一个单元格中只有值。其余的都是空的）
2. 插入作业

3. 再次合并它们以获得您想要的格式

   Dim a As Integer
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   Dim Acell As String
   Dim Bcell As String
   Dim Ccell As String
   Dim cellA As String
   Dim cellB As String
   
   i = 1
   k = 1
   
   For j = 1 To 100
      Acell = "A" & j
      Bcell = "B" & i
      Ccell = "C" & j
      cellB = "B" & k
      cellA = "A" & k
      jobRow = j
      celltext = Sheets(1).Range(Ccell)
   
      If IsEmpty(Sheets(1).Range(Ccell).Value) = True Then
         ' need the code here
          k = k + 1
      ElseIf celltext Like "*all*" Or celltext Like "*bd4*" Then
          Sheets(1).Range(Bcell).Copy Sheets(2).Range(cellB)
   
          'get jobs
          Do Until sheets(1).Cells(jobRow, 1) <> ""
             jobRow = jobRow - 1
          Loop
          Sheets(2).Range(cellA).Value = sheets(1).Cells(jobRow, 1)
   
          k = k + 1
      End If
   
      i = i + 1
   Next j
   
   'merge cells
   Application.DisplayAlerts = False
   For r = 1 To k
       Set cellTop = Sheets(2).Cells(r, 1)
       rowsBelow = r
   
       If cellTop.Value <> "" Then
          Do
             rowsBelow = rowsBelow + 1
          Loop Until cellTop.Value <> Sheets(2).Cells(rowsBelow, 1)
   
          Set cellBottom = Sheets(2).Cells(rowsBelow - 1, 1)
          Sheets(2).Range(cellTop, cellBottom).Merge
   
          r = rowsBelow
       End If
    Next r
   
    Application.DisplayAlerts = True
    End Sub