Equal Diagonal Values In Excel VBA

I have an excel file that reports on multiple departments and I would like a way to determine where certain relationships are. Below is an example. Ideally if the macro finds that the relationship exists between Row 2 and Row 3 by knowing that A2=B3 and B2=A3 it would then move Row 3’s $125.00 to D2 and delete Row 3 and go the next row where it would again find that A4=B5 and B4=A5 and then move Row 5’s $1,000.00 to D4. The code would have to be able to bypass Rows 6 and 7 (no relationship) and resume on Row 8.

Row 1 Column A Column B Column C Column D
Row 2 Team A Team B $500.00
Row 3 Team B Team A $125.00
Row 4 Team C Team D $750.00
Row 5 Team D Team C $1,000.00
Row 6 Team E Team F $1,001.00
Row 7 Team G Team H $1,002.00
Row 8 Team I Team J $1,003.00
Row 9 Team J Team I $1,004.00


Thanks!

try the following code:

Please Login or Register  to view this content.

Hi!

Thanks so much for replying!!

I think it's really close. I attached a sample file of data and I think the lines in yellow should be removed and are still there. Their value has been moved to column D but the line remains.

Sheet one is the main sheet (I think the macro was set for sheet1's) and the other SAMPLE tabs are replicated data for testing.

sample diagonal data2.xlsm

try the following code:

Formula:

Please Login or Register  to view this content.

This is terrific. It works perfectly!

My only follow up question is regarding when it's run more than once on the same data. Seems that it works exactly as needed initially, however when you run it a second time it removes additional lines - which do not meet the initial relationship criteria of diagonal matches. I've attached the file again where the macro has been run once. If you run it again you'll see that Row 14 or Index #19 (column F) is removed.

I can advise individuals to only run it once or put other controls in the file so it's not run twice+, but I wanted to at least ask.

Thanks Again!!sample diagonal data3.xlsm

replace the existing code with this.

Please Login or Register  to view this content.

Note: this code places a ' in all the cells in Column D that are not to be deleted. Though the cells appear to be blank, they are actually not. Hope that's not a deal breaker.

Not a deal breaker at all. In fact it's perfect.

I added one line to the below code because I also wanted to retain an account number along with the value before that line is deleted.

Does my "one off" addition ruin the code? It seemed to work, but I am not sure if more code is required to move a second value.




Sub Diagonal()

Dim i As Integer, j As Integer
With ThisWorkbook.Worksheets("Sheet1") 'replace Sheet1 with actual worksheet name

For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row

If .Range("D" & i) = "" Then
If .Range("A" & i) = .Range("B" & i + 1) And .Range("B" & i) = .Range("A" & i + 1) Then
.Range("D" & i) = .Range("C" & i + 1)
.Range("G" & i) = .Range("F" & i + 1) 'LINE ADDED TO MOVE A VALUE FROM G TO F BEFORE IT' DEL
.Range("D" & i + 1) = "delete"
i = i + 1
Else
.Range("D" & i) = "'"
End If
End If
Next i



For j = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If .Range("D" & j) = "delete" Then .Range("A" & j).EntireRow.Delete
Next j

End With
End Sub

Nothing more to add mate. The added line is complete by itself, and the code should work fine.
Good work!

Awesome.

Thanks again for all your help!