如果满足条件，则使用vba宏来整理数据块

Question

如附带的屏幕截图所示，我想使用vba宏自动整理数据块。

1. 示例“主要”
2. 对于下一个块数据重复相同的事情，即当“B：F”上有空单元时
3. 数据必须在下一张相应的表格中。

这是我目前的代码

Sub Sortout()
    Dim ws As Worksheet
    Sheets(1).Activate
    n = Range("B:B").Cells.SpecialCells(xlCellTypeBlanks).Count
    'MsgBox n

    m = Range("C:C").Cells.SpecialCells(xlCellTypeBlanks).Count
    'MsgBox m

    o = Range("D:D").Cells.SpecialCells(xlCellTypeBlanks).Count
    'MsgBox o

    p = Range("E:E").Cells.SpecialCells(xlCellTypeBlanks).Count
    'MsgBox p

    q = Range("F:F").Cells.SpecialCells(xlCellTypeBlanks).Count
    'MsgBox q

    If (n = m) And (o = p) And (p = n) Then
        sunday = True
        MsgBox "B:F cells are blank"
    Else
        MsgBox "B:F cells are not blank"
        sunday = False
    End If
End Sub

有人可以帮我解决这个问题吗？

Answer 1

尝试以下：

k = Range("B2:F9").Cells.SpecialCells(xlCellTypeConstants).Count   
if k=40 then
With Sheets(2)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lRow1 = Cells(Rows.Count, 1).End(xlUp).Row + 4
End With
Sheets(2).Range("A" & lRow  & ":I" & lRow1) = Sheets(1).Range("C4:K9").Value
end if

以上是“主要”。重复并替换“果汁”和“爆米花”的细胞范围

Answer 2

编辑以更正范围参考（在.cell之后添加.Range(）

Option Explicit

Sub Sortout()
    Dim cell As Range

    With Sheets(1) 'reference relevant sheet
        For Each cell In .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).SpecialCells(xlCellTypeBlanks) ' loop through its column B blank cells in range from row 1 down to last not empty one
            Sheets.Add.Name = cell.Offset(, -1) ' add a news sheet and name it after value in column A current cell row
            .Range(cell.Offset(1), cell.End(xlDown).End(xlDown)).Resize(, 5).Copy Sheets(cell.Offset(, -1).Value).Range("A1") ' copy values from range starting one cell below current one and ending 4 column left and one cell above next blank one in the same column 
        Next
    End With
End Sub

当然，你需要添加必要的检查以确保错误处理（例如：目标表已经存在，...），你可以在这里找到几十个例子