There is a sheet scr
where column P
has the following view:
P1=100
P2=100
P3=100
P4=100
P4=101
P5=101
P6=102
P7=102
P8=102
, meaning there are blocks of unique values. I need to leave only the upper value (here - P1
, P4
, P6
). The other duplicated values should be erased. Therefore, I made the code below, but it does not work and gives no error.
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
Here is your entire code over you last three questions.
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(xlUp).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
As to why your current code did not do what you wanted, Since you looped down to add the values you need to loop up to remove them:
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.