英文:
Loop to move rows to another sheet leaves one row not moved
问题
根据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
英文:
I have some data, according to the VBA code, all the rows are divided inside the sheets, but one row remains.
All rows transfer to other sheets, only row number 4 is not transferred to other sheets.
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
答案1
得分: 1
以下是您提供的VBA代码的中文翻译：
选项 显式
子宏2()
Dim wb As Workbook, ws As Worksheet, mycell As Range
Dim n As Long, ci As Long
Set wb = ThisWorkbook
对于 n = 2 到 5
wb.Sheets("Sheet" & n).Range("A1:Z10000").清除
下一个
应用程序.ScreenUpdating = 假
对于 n = 3 到 916
Set mycell = wb.Sheets("Sheet1").Cells(n, 1)
ci = 0
如果 mycell >= 24 然后
ci = 4
Set ws = Sheets("Sheet2")
ElseIf mycell.Value >= 12 然后
ci = 5
Set ws = Sheets("Sheet3")
ElseIf Len(mycell) > 0 然后 ' 跳过空白
ci = 6
Set ws = Sheets("Sheet4")
结束 如果
如果 ci > 0 然后
mycell.Interior.ColorIndex = ci
mycell.Resize(1, 16).剪切 _
目的地:=ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
结束 如果
下一个
应用程序.ScreenUpdating = 真
对于 n = 2 到 4
wb.Sheets("Sheet" & n).Columns.AutoFit
下一个
MsgBox "完成"
结束子
这是您提供的VBA宏的中文翻译，代码部分未翻译，只提供了代码的翻译部分。
英文:
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
</details>
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论