Macro to eliminate zeroes if numbers in column match and both sets of columns have zeroes

[luajambeiro]

I'm not sure if this is possible. I have a file that has as the unique identifier the JournalKey column. I need a macro that if the journal key is the same for both rows then verify if there are zeroes in each of these rows in columns E and F and H and I. Both sets of columns need to have zeroes, so both E and F have zeroes, and/or both H and I have zeroes. And if there are zeroes it should delete the value in the cell and leave it blank.

For example in the image below the following would be done:

- For rows 2 and 3 that are the same #, since both columns H and I have zeroes it would delete the zeroes and leave blank
- For rows 4 and 5 nothing would be done
- For rows 6 and 7, it would delete the zeroes in rows E and F.
- For rows 8 and 9, it would delete the zeroes in rows E and F and in rows H and I
- For rows 10 and 11, it would not delete anything because there is a value in column F and also a value in column I

template.JPG

I'm attaching this file also.

Thanks in advance.

[karmapala]

The code below is assuming that the data will always have the same pattern :
1. two same number consecutively on column A
2. so the total rows count for the whole data is always even

So, my way is something like this :
Count how many loop do I need by counting the total rows of the data divided by two.
Then do the checking for case-1 (column E and F) and for case-2 (column H and I) :

Sub test()
Set sel = Range("A2")
n = Range("A2", Range("A2").End(xlDown)).Rows.Count / 2

For i = 1 To n

'check for case-1
If sel.Offset(0, 4) = 0 And sel.Offset(1, 5) = 0 Then
sel.Offset(0, 4).Value = "" 'or maybe sel.Offset(0, 4).ClearContents
sel.Offset(1, 5).Value = "" 'or maybe sel.Offset(1, 5).ClearContents
End If

'check for case-2
If sel.Offset(0, 7) = 0 And sel.Offset(1, 8) = 0 Then
sel.Offset(0, 7).Value = ""
sel.Offset(1, 8).Value = ""
End If

'offset the sel to jump one row
Set sel = sel.Offset(2, 0)

Next i
End Sub

[luajambeiro]

Thank you Karmapala. I double-checked the data and it sometimes has entries with 3 or 4 rows with the same Journal Key so neither assumption is accurate.. Sorry for not mentioning this before.

Is there a way to do it if that's the case?

I attached an example with the different cases.

[karmapala]

Hi luajambeiro,

The code below is assuming that there is no blank row in between two cells with value in column-A.

Please try the code below :
(don't forget to remove the "B" bold "/B" attribute)

Sub test()
Set rng1 = Range("A2", Range("A2").End(xlDown))

'create a helper cells to get unique value from column A
rng1.Copy Destination:=Range("Z2")
Set rng2 = Range("Z2", Range("Z2").End(xlDown))
rng2.RemoveDuplicates Columns:=1, Header:=xlNo

'loop through each value of the unique cell
For Each r2Cell In rng2.Cells.SpecialCells(xlCellTypeConstants)

With rng1
.Replace r2Cell.Value, True, xlWhole, , False, , False, False

Set rng3 = .SpecialCells(xlConstants, xlLogical)
Set sum1 = Range(rng3.Offset(0, 4), rng3.Offset(0, 5))
Set sum2 = sum1.Offset(0, 3)

result1 = WorksheetFunction.Sum(sum1)
result2 = WorksheetFunction.Sum(sum2)

If result1 = 0 Then sum1.Cells.SpecialCells(xlCellTypeConstants).Value = ""
If result2 = 0 Then sum2.Cells.SpecialCells(xlCellTypeConstants).Value = ""

.Replace True, r2Cell.Value, xlWhole, , False, , False, False
End With

Next

'clear the cells helper
rng2.ClearContents
End Sub

The line which I bold is a code I just very knew (and learnt) in this week
from one of the senior member here, Fluff13.

Hope it works for you.

[luajambeiro]

This worked great! Thank you so much karmapala!!

[karmapala]

Glad I can help, and thanks for the rep, luajambeiro

BTW, I just realized that maybe it doesn't need the ".SpecialCells(xlCellTypeConstants)"

Sub test()
Set rng1 = Range("A2", Range("A2").End(xlDown))

'create a helper cells to get unique value from column A
rng1.Copy Destination:=Range("Z2")
Set rng2 = Range("Z2", Range("Z2").End(xlDown))
rng2.RemoveDuplicates Columns:=1, Header:=xlNo

'loop through each value of the unique cell
For Each r2Cell In rng2

With rng1
.Replace r2Cell.Value, True, xlWhole, , False, , False, False

Set rng3 = .SpecialCells(xlConstants, xlLogical)
Set sum1 = Range(rng3.Offset(0, 4), rng3.Offset(0, 5))
Set sum2 = sum1.Offset(0, 3)

result1 = WorksheetFunction.Sum(sum1)
result2 = WorksheetFunction.Sum(sum2)

If result1 = 0 Then sum1.ClearContents
If result2 = 0 Then sum2.ClearContents

.Replace True, r2Cell.Value, xlWhole, , False, , False, False
End With

Next

'clear the cells helper
rng2.ClearContents
End Sub