Question

我正在尝试创建一个循环来检查“A”列中所有单元格中的字符串（由用户定义），并切割单元格“A”不包含字符串并将其移动到另一个字符串的每一行sheet（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

非常感谢任何帮助！

[更新]这是整个宏供参考。

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

Answer 1

我会执行以下操作，但正如评论中所述，您将在您切割的范围内留下空隙。在这种情况下，之后删除空行是个好主意。假设工作表中的值被格式化为字符串。

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

尝试创建一个循环，根据单元格值将行移动到不同的工作表

1 个答案: