Deleting rows via an if statement

[jaypatel]

Hi all,

Firstly, Merry Christmas to everyone who has used mrexcel over the past year.

i have an userform which inserts into cell a2, a text field, say "membership income".(please note that cell a2 is variable) and cell a2 should be matched upto cells in column d.

how would u develop a macro that will check all the cells in column d equals a2 or not.

so if cell a2=dx then do not delete row x where x is the row number.

examples being....

if a2=d1 then do not delete row
if a2 does not equal d2 then delete row 2
if a2 does not equal d3 then delete row 3 etc
upto row 65536.

Cheers

Jay

 

[Legacy 21301]

Sub ZapRows()
Dim a2Val$, rng As Range
Dim lastCell As Range
Dim destSh As Worksheet
Set destSh = Sheets("ExtractData")

Sheets("SourceSheet").Activate 'Re-name as required
a2Val = [A2].Value
If Len(a2Val) = 0 Then Exit Sub
If Len([D65536]) <> 0 Then
    Set lastCell = [D65536]
Else
    Set lastCell = [D65536].End(xlUp)
End If

Application.ScreenUpdating = False
destSh.[D:E].Insert
[D:E].Insert
Set rng = Range([E1], lastCell(1, 0))
With rng
    .Offset(0, -1)(1) = 1
    .Offset(0, -1)(1).AutoFill Destination:=rng.Offset(0, -1), Type:=xlFillSeries
    .FormulaR1C1 = "=IF(RC[1]=R2C1,1,"""")"
    .Value = .Value
    .EntireRow.Sort Key1:=[E1], Order1:=xlAscending, Header:=xlNo
    On Error Resume Next
    .SpecialCells(xlBlanks).EntireRow.Copy destSh.[F65536].End(xlUp)(2, -4)
    On Error GoTo 0
    .EntireRow.Sort Key1:=[D1], Order1:=xlAscending, Header:=xlNo
End With
destSh.[D:E].Delete
[D:E].Delete
[A2] = a2Val
Application.ScreenUpdating = True
End Sub

 

[jaypatel]

Hi P,

Sorry about this.... but all it does is extract all the information from sheet 2 to extractdata sheet. (unless I am doing something wrong).

with the conditions set ie if cell a2=cell d2, a2=d3 etc, i just want to extract these lines to extractdata sheet.

Cheers

Jay

 

[Legacy 21301]

Change the line that reads :-

.FormulaR1C1 = "=IF(RC[1]=R2C1,1,"""")"

To :-

.FormulaR1C1 = "=IF(RC[1]=R2C1,"""",1)"

 

[jaypatel]

Hi Ponsy Nob,

I have tried this.... but for some unknown reason it extracts all the information twice....... not sure why. (I have doubled checked my calculations).

Jay

 

[Legacy 21301]

Works for me.

Post the actual code that you have in your workbook.

 

[jaypatel]

Hi P,

This is the code i have:

Sub ZapRows()
Dim a2Val$, rng As Range
Dim lastCell As Range
Dim destSh As Worksheet
Set destSh = Sheets("ExtractData")

Sheets("Sheet3").Activate 'Re-name as required
a2Val = [A2].Value
If Len(a2Val) = 0 Then Exit Sub
If Len([D65536]) <> 0 Then
Set lastCell = [D65536]
Else
Set lastCell = [D65536].End(xlUp)
End If

Application.ScreenUpdating = False
destSh.[D:E].Insert
[D:E].Insert
Set rng = Range([E1], lastCell(1, 0))
With rng
.Offset(0, -1)(1) = 1
.Offset(0, -1)(1).AutoFill Destination:=rng.Offset(0, -1), Type:=xlFillSeries
.FormulaR1C1 = "=IF(RC[1]=R2C1,"""",1)"
.Value = .Value
.EntireRow.Sort Key1:=[E1], order1:=xlAscending, Header:=xlNo
On Error Resume Next
.SpecialCells(xlBlanks).EntireRow.Copy destSh.[F65536].End(xlUp)(2, -4)
On Error GoTo 0
.EntireRow.Sort Key1:=[D1], order1:=xlAscending, Header:=xlNo
End With
destSh.[D:E].Delete
[D:E].Delete
[A2] = a2Val
Application.ScreenUpdating = True
End Sub

Jay

 

[jaypatel]

Hi P

I dont know if this helps but i have columns a-j inclusive filled with data.... column K is blank and column L is filled with data.

Jay

 

[Legacy 21301]

That doesn't make any difference.

There is nothing in the macro that causes the data to be copied/pasted twice.

Either the code you are using is different or you also have some other macro that does the same thing and is being run as well.

Try stepping through your macro (via F8) to see where your code is copying/pasting twice.

 

[jaypatel]

Sorry P,

My mistake... it does work..Checked my code. I had it twice..... once in the auto open routine and once when someone clicked the command button.

Jay