尝试创build一个循环，根据单元格值将行移动到不同的工作表
我试图做一个循环检查string（由用户定义）在列“A”中的所有单元格，并削减单元格“A”不包含string，并将其移动到另一个工作表（Cml ）我有下面的代码运行没有任何错误消息，但它似乎并没有做它应该的。
Sub PSFormat() Dim cb As Shape Dim Cml As Worksheet Dim Aud As Worksheet Dim z As Long, LastRow As Long Dim myDate2 As String Set Aud = Worksheets("CURRENT") Set Cml = Worksheets("OLD") myDate2 = InputBox("Please enter the date you are reviewing in yyyy-mm-dd format") With Aud LastRow = Aud.Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A" For z = 2 To LastRow If InStr(Aud.Range("A" & z).Value2, myDate2) < 0 Then ' check if current cell in column "A" contains "myDate2" defined by the user 'if the cell in col "A" doesn't contain "myDate2" then cut the entire row and paste it to sheet Cml Aud.Rows((1) & z).EntireRow.Cut _ Destination:=Cml.Rows((1) & z) End If Next z End With End Sub 任何帮助将不胜感激！
[更新]这是供参考的整个macros。
Sub PSFormat() Dim cb As Shape Dim Cml As Worksheet Dim Aud As Worksheet Dim z As Long, LastRow As Long Dim myDate2 As String Set Aud = Worksheets("CURRENT") Set Cml = Worksheets("OLD") myDate2 = InputBox("Please enter the date you are reviewing in yyyy-mm-dd format") Aud.Range("A1").EntireRow.Insert Aud.Range("A1").Value = "TIME" Aud.Range("B1").Value = "ACTION" Aud.Range("C1").Value = "PLATFORM" Aud.Range("D1").Value = "MAKER ID" Aud.Range("E1").Value = "APPLICATION" Aud.Range("F1").Value = "JUSTIFICATION" Aud.Range("A1:F1").AutoFilter LastRow = Aud.Cells(Rows.Count, "B").End(xlUp).Row For x = 1 To LastRow If Aud.Range("D" & x).Value <> "PSECSELF" Then Aud.Range("F" & x).Value = "A" If Aud.Range("D" & x).Value = "PSECSELF" Then Aud.Range("F" & x).Value = "N/A" If Aud.Range("B" & x).Value = "Unsuccessful login attempt" Then Aud.Range("F" & x) = "N/A" If Aud.Range("B" & x).Value = "Administrator login" Then Aud.Range("F" & x) = "N/A" If Aud.Range("B" & x).Value = "Remote help successful" Then Aud.Range("F" & x) = "N/A" If Aud.Range("B" & x).Value = "Helpdesk user deleted" Then Aud.Range("F" & x) = "N/A" If Aud.Range("B" & x).Value = "Token deleted" Then Aud.Range("F" & x) = "N/A" Next x With Aud LastRow = Aud.Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A" For z = 2 To LastRow If InStr(Aud.Range("A" & z).Value2, myDate2) < 0 Then ' check if current cell in column "A" contains "myDate2" defined by the user 'if the cell in col "A" doesn't contain "myDate2" then cut the entire row and paste it to sheet Cml Aud.Range("A" & z).EntireRow.Cut _ Destination:=Cml.Rows((1) & z) End If Next z End With Aud.Range("F1").Value = "JUSTIFICATION" Aud.Range("F2").AutoFilter Field:=6, Criteria1:="A" Aud.Buttons.Add(617.25, 24, 72, 72).Select Selection.OnAction = "PSSaveFile" Selection.Characters.Text = "SAVE" Aud.Range("F2").Select MsgBox "Please filter for yesterday's date first!" End Sub
我会做下面的事情，但正如评论中指出的那样，你在离开的范围上留下了一个空白。 在这种情况下，之后删除空行是个好主意。 假定工作表中的值被格式化为string。
Option Explicit Sub PSFormat() Dim cb As Shape Dim Cml As Worksheet Dim Aud As Worksheet Dim z As Long, LastRow As Long Dim myDate2 As String Dim LastRowOld As Long Dim cutRange As Range Set Aud = Worksheets("CURRENT") Set Cml = Worksheets("OLD") myDate2 = InputBox("Please enter the date you are reviewing in yyyy-mm-dd format") With Aud LastRow = Aud.Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A" LastRowOld = Cml.Cells(.Rows.Count, "A").End(xlUp).Row For z = 2 To LastRow If Not IsEmpty(Aud.Range("A" & z)) And InStr(Aud.Range("A" & z).Value2, myDate2) =0 Then Then ' check if current cell in column "A" contains "myDate2" defined by the user If Not cutRange Is Nothing Then Set cutRange = Union(cutRange, Aud.Range("A" & z)) Else Set cutRange = Aud.Range("A" & z) End If 'if the cell in col "A" doesn't contain "myDate2" then cut the entire row and paste it to sheet Cml End If Next z End With If Not cutRange Is Nothing Then cutRange.Copy Cml.Cells(LastRowOld, "A") cutRange.Delete End If End Sub