Question

有一个工作表scr，其中列P具有以下视图：

P1=100
P2=100
P3=100
P4=100
P4=101
P5=101
P6=102
P7=102
P8=102

，意味着存在唯一值块。我只需要保留较高的值（此处为P1，P4，P6）。应删除其他重复的值。因此，我在下面编写了代码，但它不起作用并且没有错误。

Sub Test()

Dim wb1 As Workbook                                                 
Set wb1 = ActiveWorkbook                                            
Set src = wb1.Sheets("Modules_List")                                

Application.ScreenUpdating = False                                  
Application.Calculation = xlCalculationManual
Dim i As Long
Dim k As Integer
With src
    For i = 1 To 100
        For k = 1 To 100
            If .Cells(i, "P").Value = .Cells(i + k, "P").Value Then .Cells(i + k, "P").Value = ""
        Next k
    Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Answer 1

以上是您最后三个问题的完整代码。

Sub Copy_Data_by_Criteria()

    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim src As Worksheet
    Dim Dst As Worksheet
    Dim src2 As Worksheet


    Set wb1 = ActiveWorkbook
    Set wb2 = Workbooks.Open(Filename:="C:\Test.xlsx")
    Set src = wb1.Sheets("Sheet1")
    Set Dst = wb2.Sheets("Sheet1")
    Set src2 = wb1.Sheets("Base 1")

    Dim LastRow As Long
    Dim r As Range
    Dim CopyRange As Range
    Dim Crit As Range
    Dim strValue As Variant
    LastRow = src.Cells(src.Rows.Count, "P").End(x1Up).Row

    For Each Crit In src2.Range("G10:G" & 30)
        If Crit <> "" Then
            For Each r In src.Range("P6:P" & LastRow)

                If r <> 0 Then strValue = r

                If strValue = Crit Then
                    If CopyRange Is Nothing Then
                            Set CopyRange = r.EntireRow
                    Else
                            Set CopyRange = Union(CopyRange, r.EntireRow)
                    End If
                End If
            Next r
        End If
    Next Crit
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Dst.Range("A1")
    End If

End Sub

至于为什么你当前的代码没有按你想要的那样做，因为你循环添加你需要循环删除它们的值：

Sub Test()

Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
Set src = wb1.Sheets("Modules_List")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim k As Integer
With src
    For i = 100 To 1
        If .Cells(i, "P").Value = .Cells(i - 1, "P").Value Then .Cells(i, "P").Value = ""
    Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

删除列中的重复值，只留下行数较高的值

1 个答案: