PDA

View Full Version : Solved: Delete specific cells not entire row



BENSON
02-05-2009, 07:38 PM
The last part of thecode below checks for duplictes in collum H and if any are foundwill delete the entire row.I wish to alter the code so that cells in collum H:K and V:AB are deleted not the entire row. so for example say cell H10 was a duplict cells H10:K10 and celss V10:AB10 would be deleted.
THANKS


Sub Button3_Click()
a = MsgBox("ARE YOU READY TO UPDATE THE HISTORY FILE?", _
vbYesNo)

If a = vbYes Then
Cancel = True
Dim WsTgt As Excel.Worksheet
Dim rngCopy As Excel.Range
Application.ScreenUpdating = False
Workbooks.Open Filename:= _
"L:\Documents and Settings\NPC.xls", UpdateLinks:=3
Windows("NPB.xls").Activate
Set WsTgt = Workbooks("NPC.xls").Sheets("GD")
With WsTgt.Range("h" & NextEmptyRow(WsTgt))


ActiveSheet.Range("C8:c35").Copy
.Offset(, 0).PasteSpecial xlPasteValues
ActiveSheet.Range("E8:G35").Copy
.Offset(, 1).PasteSpecial xlPasteValues
ActiveSheet.Range("J8:J35").Copy
.Offset(, 14).PasteSpecial xlPasteValues
ActiveSheet.Range("M8:M35").Copy
.Offset(, 15).PasteSpecial xlPasteValues
ActiveSheet.Range("O8:O35").Copy
.Offset(, 16).PasteSpecial xlPasteValues
ActiveSheet.Range("P8:P35").Copy
.Offset(, 17).PasteSpecial xlPasteValues
ActiveSheet.Range("Q8:Q35").Copy
.Offset(, 18).PasteSpecial xlPasteValues
ActiveSheet.Range("R8:R35").Copy
.Offset(, 19).PasteSpecial xlPasteValues
ActiveSheet.Range("I8:I35").Copy
.Offset(, 20).PasteSpecial xlPasteValues
Windows("NPC.xls").Activate


Dim wSheet As Worksheet
Dim x As Long
Dim LastRow As Long
Application.ScreenUpdating = False
Sheets(1).Select
For Each wSheet In Worksheets
wSheet.Select
LastRow = Range("h" & Rows.Count).End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("h1:h" & x), Range("h" & x).Value) > 1 Then
Range("h" & x).EntireRow.Delete
End If
Next x
Next wSheet


Application.ScreenUpdating = True
End With
End If
End Sub

duluter
02-05-2009, 07:47 PM
If you find a duplicate, you could use this to delete the cell range and move the cells below it up.

Range("H" & x & ":K" & x).Delete Shift:=xlUp
Range("V" & x & ":AB" & x).Delete Shift:=xlUp
Where x is the row number.