时间戳

首页 > 解决方案 > 复制粘贴然后删除 For Each 循环中的行会跳过每隔一行

excel - 复制粘贴然后删除 For Each 循环中的行会跳过每隔一行

问题描述

我正在搜索具有删除线的任何单元格的范围，如果检测到删除线，则整行将被复制粘贴到同一工作簿的另一个工作表中。

我还在搜索带有删除线的单元格上方的所有单元格，寻找第一个具有interior.color = rgb(0,0,0) 的单元格，一旦发现它也会将该数据放在另一个工作表上。

Private Sub CommandButton1_Click()

Dim ipWS As Worksheet, compWS As Worksheet
Dim compDest As Range, rrCell As Range
Dim alastRow As Long

Set ipWS = ThisWorkbook.Worksheets("In Processing")
Set compWS = ThisWorkbook.Worksheets("Completed")
Set compDest = compWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

alastRow = ipWS.Cells(Rows.Count, "A").End(xlUp).Row

Dim rackRng As Range
Dim cellRng As Range
 
Application.FindFormat.Interior.Color = RGB(0, 0, 0)

For Each rrCell In ipWS.Range("A1:A" & alastRow).Cells

    If rrCell.Font.Strikethrough = True Then
    
        Set cellRng = ipWS.Range(rrCell, rrCell.End(xlToRight))
        cellRng.Copy compDest.Offset(0, 1)
        'Application.CutCopyMode = False
            
        Set rackRng = ipWS.Range(rrCell, rrCell.End(xlUp)).Find("*", , , , , xlPrevious, , , SearchFormat:=True)
        rackRng.Copy compDest
        'Application.CutCopyMode = False
            
        ipWS.Range(rrCell, rrCell.End(xlToRight)).EntireRow.Delete
            
        Set compDest = compDest.Offset(1, 0)
    End If
Next rrCell
   
With compWS.Range("A:P")
    .Font.Strikethrough = False
    .ColumnWidth = 25
    .Font.Size = 14
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlVAlignCenter
End With

End Sub

如果我有 < 2 个带有删除线的单元格，则该代码有效。一旦我有> 2个带有删除线的单元格，它就会开始识别带有删除线的所有其他单元格，并将它们留在原始工作表上。

如果我再次点击该按钮，那么被跳过的那些将移至目标工作表。

这里有一些照片
在此处输入图像描述

跳过的单元格

目标工作表

第二张图是我第一次点击按钮的结果。它识别带有删除线的第一个单元格，然后跳过下一个单元格，然后抓取第三个单元格。
如果我再次按下按钮，那么被跳过的按钮将转到工作表。

Application.cutcopymode = false被注释掉，因为这似乎不起作用。

我试图抓住每一个机会都调出这两个工作表，但这没有用。

标签： excelvba

解决方案

感谢@Siddharth Rout 提供正确方向的提示。


Private Sub CommandButton1_Click()

Dim ipWS As Worksheet, compWS As Worksheet
Dim compDest As Range, rrCell As Range
Dim i As Integer
Dim alastRow As Long

Set ipWS = ThisWorkbook.Worksheets("In Processing")
Set compWS = ThisWorkbook.Worksheets("Completed")


alastRow = ipWS.Cells(Rows.Count, 1).End(xlUp).Row


Dim rackRng As Range
Dim cellRng As Range

Set compDest = compWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

Application.FindFormat.Interior.Color = RGB(0, 0, 0)


For i = alastRow To 1 Step -1

            
            If Range(Cells(i, 1), Cells(i, 1)).Font.Strikethrough = True Then
           
                Set rackRng = ipWS.Range(Cells(i, 1), Cells(i, 1).End(xlUp)).Find("*", , , , , xlPrevious, , , SearchFormat:=True)
                    rackRng.Copy compDest
                        Application.CutCopyMode = False
                
                Range(Cells(i, 1), Cells(i, Columns.Count).End(xlToLeft)).Copy compDest.Offset(0, 1)
                    Application.CutCopyMode = False
                
                        Set compDest = compDest.Offset(1, 0)
                    
                    Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
            End If

Next i
            With compWS.Range("A:P")
                .Font.Strikethrough = False
                .ColumnWidth = 25
                .Font.Size = 14
                .WrapText = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlVAlignCenter
            End With

End Sub

推荐阅读