excel 循环将行移动到另一个工作表时，仍有一行不移动

uqjltbpv 于 2023-04-13 发布在其他

关注(0)|答案(1)|浏览(97)

我有一些数据，根据VBA代码，所有的行都在工作表内划分，但有一行保留。
所有行都转移到其他图纸，只有行号4不转移到其他图纸。

Sub ap()
Dim mycell As Range
Dim myrange As Range
Worksheets("sheet2").Range("a1:z10000").Clear
Worksheets("sheet3").Range("a1:z10000").Clear
Worksheets("sheet4").Range("a1:z10000").Clear
Worksheets("sheet5").Range("a1:z10000").Clear
Set myrange = Worksheets("sheet1").Range("a3:a916")
For Each mycell In myrange
    If mycell.Value >= 12 Then
        If mycell.Value >= 24 Then
            mycell.Interior.ColorIndex = 4
            mycell.Resize(1, 16).Cut Destination:= _
              Worksheets("sheet2").Range("a1").Offset(Worksheets("sheet2").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
        Else
            mycell.Interior.ColorIndex = 5
            mycell.Resize(1, 16).Cut Destination:= _
              Worksheets("sheet3").Range("a1").Offset(Worksheets("sheet3").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
        End If
    Else
        mycell.Interior.ColorIndex = 6
        mycell.Resize(1, 16).Cut Destination:= _
          Worksheets("sheet4").Range("a1").Offset(Worksheets("sheet4").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
    End If
Next
Worksheets("sheet2").Columns.AutoFit
Worksheets("sheet3").Columns.AutoFit
Worksheets("sheet4").Columns.AutoFit
End Sub

excel

来源：https://stackoverflow.com/questions/75897794/loop-to-move-rows-to-another-sheet-leaves-one-row-not-moved

1条答案

按热度按时间

sqserrrh1#

Option Explicit
Sub Macro2()

    Dim wb As Workbook, ws As Worksheet, mycell As Range
    Dim n As Long, ci As Long
    
    Set wb = ThisWorkbook
    For n = 2 To 5
        wb.Sheets("Sheet" & n).Range("A1:Z10000").Clear
    Next
    
    Application.ScreenUpdating = False
    For n = 3 To 916
        Set mycell = wb.Sheets("Sheet1").Cells(n, 1)
        ci = 0
        If mycell >= 24 Then
            ci = 4
            Set ws = Sheets("Sheet2")
        ElseIf mycell.Value >= 12 Then
            ci = 5
            Set ws = Sheets("Sheet3")
        ElseIf Len(mycell) > 0 Then ' skip blanks
            ci = 6
            Set ws = Sheets("Sheet4")
        End If
        If ci > 0 Then
            mycell.Interior.ColorIndex = ci
            mycell.Resize(1, 16).Cut _
               Destination:=ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next
    Application.ScreenUpdating = True
    
    For n = 2 To 4
        wb.Sheets("Sheet" & n).Columns.AutoFit
    Next
    MsgBox "Done"

End Sub

赞(0）回复(0）举报 2023-04-13

我来回答

excel 循环将行移动到另一个工作表时，仍有一行不移动

1条答案

相关问题

热门标签

最新问答