Need every 3 rows to have row 2 and 3 appended to end of row 1

[kmw875]

Hello Excel Helpers,

I am new to the forum and fairly new to VBA in general. I record most macros which I use. This one however is a bit more tricky and I need some expert help.

I have a spreadsheet of patient accounting which we get regularly from a client. I have a sample mock sheet that I can submit just for a visual to help explain what I need. But the sheet comes in the same format each time only the data changes, the first 3 rows are the headings. Each records is 3 rows long. Headings are from A1 to Q3. Some of the cells are merged but I still need them to copy exactly as is.

The problem I have is that I have to filter out all patients records who have a code of "9MK" in Column N. I thought the easiest way would be to convert all three rows to one long row and then filter on that specific column instead of staff going through and deleting the rows manually for the records that do not have 9MK. Trying to figure out how to attach file with code that I have. Any suggestion is truly appreciated.

Thank you, Kim

 

[ProfessorPorcupine]

Try this, it loops through each three lines looking for if the code is not 9MK. You have to loop upwards since you are deleting rows.

Sub DeleteExcessRecords()
'Deletes records that are not designated "9MK"
Dim wksData As Worksheet
Dim lngCounter As Long
Dim lngFinalRow As Long

Set wksData = ThisWorkbook.Sheets(1)
wksData.Activate
lngFinalRow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 14).End(xlUp).Row
For lngCounter = lngFinalRow - 2 To 4 Step -3
If wksData.Cells(lngCounter, 14) <> "9MK" Then
wksData.Rows(lngCounter + 2).Delete
wksData.Rows(lngCounter + 1).Delete
wksData.Rows(lngCounter).Delete
End If
Next
End Sub

 

[kmw875]

Thank you very much for trying to help me! The code for 9MK is in column N and would be in the 2nd row of each account if it exists. I have a small set of sample data I tested your code on. 27 rows, first 3 are the header rows. The code deleted every row other then the 3 top/header rows. I have 7 test accounts, of which 3 have 9MK as the test data, but those did not remain.

 

[ProfessorPorcupine]

Since the code for 9MK is in the second row of each account and not the first, you just need to make a small adjustment as below:
Sub DeleteExcessRecords()
'Deletes records that are not designated "9MK"
Dim wksData As Worksheet
Dim lngCounter As Long
Dim lngFinalRow As Long

Set wksData = ThisWorkbook.Sheets(1)
wksData.Activate
lngFinalRow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 14).End(xlUp).Row
For lngCounter = lngFinalRow - 1 To 5 Step -3
If wksData.Cells(lngCounter, 14) <> "9MK" Then
wksData.Rows(lngCounter + 1).Delete
wksData.Rows(lngCounter).Delete
wksData.Rows(lngCounter - 1).Delete
End If
Next
End Sub