Question

我一直在尝试解决我正在处理的工作表的问题，但是我对vba的了解有限，使我陷入困境。

我目前拥有的代码是，如果记录的Y列中值为“ CHK”，则该代码将记录的参考编号（A列）复制到新的工作表中。此代码如下所示。

我遇到的问题是尝试添加一些代码，这意味着当我运行宏时，将仅复制符合条件的新条目。当我运行宏时，它会复制已经复制的条目（即我运行一次宏并获得1,2,3，然后再次运行它，添加另一个单元格，并获得1,2,3,1 ，2,3,4。

我一直在尝试提出想法和想法，以使用“ If”来比较我复制到的工作表和登记表中的最终参考号。然后设置一个类似的过程，该过程将只复制比我要复制的工作表中最终参考编号大的值。这将要求我建立与以下相同的过程，但仅限于大于我要复制的工作表中最终值的值。

我认为这将需要两个宏，一个宏用于第一次填充列表（下面的代码），然后一个宏用于运行更新，如前所述。

我的问题是，此过程会起作用吗？或者，我是否缺少更好的方法来实现我需要实现的目标。

谢谢。

Sub Copy_detailed_WithNum_V4_Test()

'Create and set worksheet variables
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")

'Create search range, cel and lastrow variable 
Dim SrchRng As Range, cel As Range, Lastrow As Long

'Set the range to search as column Y in the detailed register (Y2 to last used cell in Y)
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)

'Stop screen updating with each action
Application.ScreenUpdating = False

For Each cel In SrchRng

    'Check if the VIPP Flag for the entry is CHK
    If InStr(1, cel.Text, "CHK") Then
        'If the entry is CHK, set the lastrow variable as first empty cell in row a of the VIPP Register
        Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
        'Set the value of cells in Column A in VIPP Register to be equal to record number values for those entries that require a VIPP CHK
        ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
    End If
'Repeat for next cell in the search range
Next cel
Application.ScreenUpdating = True

End Sub

Answer 1

我相信这可以解决问题。

您可以单独运行宏，也可以添加Call RemoveDuplicates，然后结束第一个子控件。

Sub RemoveDuplicates()

Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim Unique As Range: Set Unique = ws2.Range("A2:A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row)
Dim MyCell As Range, DeleteMe As Range

For Each MyCell In Unique
    If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), MyCell) > 1 Then
        If DeleteMe Is Nothing Then
            Set DeleteMe = MyCell
        Else
            Set DeleteMe = Union(DeleteMe, MyCell)
        End If
    End If
Next MyCell

If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete

End Sub

这应该检查您的值是否在粘贴之前就存在，这意味着该子项就足够了。

Sub Copy_detailed_WithNum_V4_Test()

Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim SrchRng As Range, cel As Range, Lastrow As Long

Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)

Application.ScreenUpdating = False
For Each cel In SrchRng    
  If InStr(1, cel.Text, "CHK") Then
        If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), cel.Offset(0, -24)) = 0 Then
            Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
            ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
        End If
    End If
Next cel
Application.ScreenUpdating = True

End Sub

仅复制工作表中符合条件的新条目，并在另一工作表的列末添加

1 个答案: