macros来解开空白单元格之间的单元格

我有一张包含所有天数信息的主表。 我想将这些信息复制到另一个基于column C提到的选定date。 我能够复制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 

结果应该是这样的结果

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