Question

所以我有我的主表单，我运行宏来复制模板，然后根据一列中的值填充某些行。我需要添加一个签入，这样我就可以告诉它如果另一列中的值与指定的条件匹配则不要拉行。例如，如果列Y中的值与1234匹配，则行x将被拉出，但仅当列Z中的值与456不匹配时才会被拉出。这是我现在正在使用的代码：

Option Explicit

Sub Report()
    CreateDeptReport "Report"
End Sub


Sub CreateDeptReport(Report As String)

    Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
    Dim LCopyToRow As Long
    Dim LCopyToCol As Long
    Dim arrColsToCopy
    Dim c As Range, X As Integer

    On Error GoTo Err_Execute

    arrColsToCopy = Array(1, 3, 4, 8, 25, 16, 17, 15, 31, 7, 26) 'which columns to copy ?

    Set shtMaster = ThisWorkbook.Sheets("RawData")
    Set c = shtMaster.Range("Y5")  'Start search in Row 5

    LCopyToRow = 10 'Start copying data to row 10 in Mental

    While Len(c.Value) > 0
        'If value in column Y ends with "2135", copy to report sheet
       If c.Value Like "*2135" Then

            'only create the new sheet if any records are found
            If shtRpt Is Nothing Then
                'delete any existing sheet
                On Error Resume Next
                Application.DisplayAlerts = False
                ThisWorkbook.Sheets("NewSheetName").Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                ThisWorkbook.Sheets("Template").Copy After:=shtMaster
                Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1)
                shtRpt.Name = "NewSheetName" 'rename new sheet to NewSheetName
                Range("F1").Value = "XXXX"
                Range("F2").Value = "XXXX"
                Range("B3").Value = Date
                Range("B4").Value = "XXXX"            
            End If

            LCopyToCol = 1

            shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown

            For X = LBound(arrColsToCopy) To UBound(arrColsToCopy)

                shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
                            c.EntireRow.Cells(arrColsToCopy(X)).Value

                LCopyToCol = LCopyToCol + 1

            Next X

            LCopyToRow = LCopyToRow + 1 'next row
        End If
        Set c = c.Offset(1, 0)
    Wend

    ThisWorkbook.Worksheets("NewSheetName").Rows("9:9").Delete

    Range("A9").Select 'Position on cell A9
    MsgBox "All matching data has been copied."
    Exit Sub

Err_Execute:
        MsgBox "An error occurred."
End Sub

这就是我所拥有的;我想做尽可能少的重组，因为我知道这正是我想要的，除了这一个愚蠢的皱纹。我已经尝试在c.Value线附近添加条件，但我没有到达任何地方。谢谢你的建议！

Answer 1

你的第一个标准范围标记为“c”，所以让我们称你的第二个“d”。在适当的位置添加以下行：

在所有其他Dim声明之后，添加
Dim d as range
在set c行之后，添加
Set d = shtMaster.Range("Y5")
更改
If c.Value Like "*2135" Then到
If c.Value Like "*2135" and d.Value not like "*456*" Then
在Wend添加之前 Set d = d.Offset(1, 0)

我可能错过了一两行，但基本上我正在尝试保持相同的逻辑模式并复制更改c变量的行。（如果我错过了一两行，请在评论中指出它们）

尝试从主工作表中过滤掉一行，但在宏期间不会复制到个人

1 个答案: