Excel Macro Combine Two Rows to New Row

larspanky
larspanky used Ask the Experts™
on
I have a macro that I need to change.   The source report has about 1500 rows of data.  representing a number of store locations.  The latest location had a small change of format throwing off my report.

The report assigns a number for sorting in column J that later gets deleted. 23 of them have a field called Visa/M.C.   The new stores have Visa and Master Card on seperate lines.   The Label for sorting is 25 in Visa/M.C. and I assigned Visa to 25a and MasterCard to 25b.  Here is what I need to do.
Search the document.
Identify 25a and 25b, Insert a new row below 25b and label it 25 in column J.  take the data from a and b and add a total for 25 in columns G and H.  Fill in the remaining data (lables and a date) and delete 25a and 25b leaving the new row 25 behind.  

I am not sure how to call the functions based on this ID.  Open to suggestions.
The code is how I am placing the ID in the rows.  

Thanks
Sub IDFields()

    Range("E10").Select
    Do Until IsEmpty(ActiveCell)
    If ActiveCell = "Food-Breakfast" Then ActiveCell.Offset(0, 5) = "1"
    If ActiveCell = "Food-A.B." Then ActiveCell.Offset(0, 5) = "2"
    If ActiveCell = "Beverage" Then ActiveCell.Offset(0, 5) = "3"
    If ActiveCell = "Merchandise" Then ActiveCell.Offset(0, 5) = "4"
    If ActiveCell = "Gift Card Sold" Then ActiveCell.Offset(0, 5) = "5"
    If ActiveCell = "Gift Card Redeemed" Then ActiveCell.Offset(0, 5) = "6"
    If ActiveCell = "Tips Due" Then ActiveCell.Offset(0, 5) = "7"
    If ActiveCell = "Carried Over" Then ActiveCell.Offset(0, 5) = "8"
    If ActiveCell = "= TOTAL OUTSTANDING" Then ActiveCell.Offset(0, 5) = "9"
    If ActiveCell = "Manager Discounts" Then ActiveCell.Offset(0, 5) = "10"
    If ActiveCell = "Employee Discounts" Then ActiveCell.Offset(0, 5) = "11"
    If ActiveCell = "Senior Discounts" Then ActiveCell.Offset(0, 5) = "12"
    If ActiveCell = "Government Discounts" Then ActiveCell.Offset(0, 5) = "13"
    If ActiveCell = "Coupon/FSI Discounts" Then ActiveCell.Offset(0, 5) = "14"
    If ActiveCell = "Training Discounts" Then ActiveCell.Offset(0, 5) = "15"
    If ActiveCell = "B to B Discounts" Then ActiveCell.Offset(0, 5) = "16"
    If ActiveCell = "Other Discounts" Then ActiveCell.Offset(0, 5) = "17"
    
    If ActiveCell = "= TOTAL DISCOUNTS" Then ActiveCell.Offset(0, 5) = "18"
    If ActiveCell = "House Charge" Then ActiveCell.Offset(0, 5) = "19"
    If ActiveCell = "+ Tax Collected" Then ActiveCell.Offset(0, 5) = "20"
    
    If ActiveCell = "Cash" Then ActiveCell.Offset(0, 5) = "21"
    If ActiveCell = "Amex" Then ActiveCell.Offset(0, 5) = "22"
    If ActiveCell = "Diners / C.B." Then ActiveCell.Offset(0, 5) = "23"
    If ActiveCell = "Discover" Then ActiveCell.Offset(0, 5) = "24"
    If ActiveCell = "Visa / M.C." Then ActiveCell.Offset(0, 5) = "25"
    If ActiveCell = "Visa" Then ActiveCell.Offset(0, 5) = "25a"
    If ActiveCell = "MasterCard" Then ActiveCell.Offset(0, 5) = "25b"
    If ActiveCell = "- Tips Paid" Then ActiveCell.Offset(0, 5) = "26"
    If ActiveCell = "= TOTAL EXPECTED DEPOSIT" Then ActiveCell.Offset(0, 5) = "27"
    
    ActiveCell.Offset(1, 0).Select
    Loop
    Cells.Select
    Range("A1344").Activate
    
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2008

Commented:
are lines 25a and 25b after each other?
are there any other lines that shouldn't be combined?

do you have a sample file?

The attached code assumes that each 25b has a 25a above it, and that only columns G and H are updated on the new line.

Thomas

Sub IDFields()

Dim lastRow As Long, i As Long

Application.ScreenUpdating = False

For i = 10 To lastRow
    Select Case Cells(i, 5)
        Case "Food-Breakfast"
            Cells(i, "J") = "1"
        Case "Food-A.B."
            Cells(i, "J") = "2"
        Case "Beverage"
            Cells(i, "J") = "3"
        Case "Merchandise"
            Cells(i, "J") = "4"
        Case "Gift Card Sold"
            Cells(i, "J") = "5"
        Case "Gift Card Redeemed"
            Cells(i, "J") = "6"
        Case "Tips Due"
            Cells(i, "J") = "7"
        Case "Carried Over"
            Cells(i, "J") = "8"
        Case "= TOTAL OUTSTANDING"
            Cells(i, "J") = "9"
        Case "Manager Discounts"
            Cells(i, "J") = "10"
        Case "Employee Discounts"
            Cells(i, "J") = "11"
        Case "Senior Discounts"
            Cells(i, "J") = "12"
        Case "Government Discounts"
            Cells(i, "J") = "13"
        Case "Coupon/FSI Discounts"
            Cells(i, "J") = "14"
        Case "Training Discounts"
            Cells(i, "J") = "15"
        Case "B to B Discounts"
            Cells(i, "J") = "16"
        Case "Other Discounts"
            Cells(i, "J") = "17"
        Case "= TOTAL DISCOUNTS"
            Cells(i, "J") = "18"
        Case "House Charge"
            Cells(i, "J") = "19"
        Case "+ Tax Collected"
            Cells(i, "J") = "20"
        Case "Cash"
            Cells(i, "J") = "21"
        Case "Amex"
            Cells(i, "J") = "22"
        Case "Diners / C.B."
            Cells(i, "J") = "23"
        Case "Discover"
            Cells(i, "J") = "24"
        Case "Visa / M.C."
            Cells(i, "J") = "25"
        Case "Visa"
            Cells(i, "J") = "25a"
        Case "MasterCard"
            Cells(i, "J") = "25b"
        Case "- Tips Paid"
            Cells(i, "J") = "26"
        Case "= TOTAL EXPECTED DEPOSIT"
            Cells(i, "J") = "27"
    End Select 'Select Cells(i, 5)
Next i

For i = lastRow To 10 Step -1
    If Cells(i, "J") = "25b" Then
        Rows(i + 1).Insert
        Cells(i + 1, "J") = "25"
        Cells(i + 1, "G") = Cells(i, "G") + Cells(i - 1, "G")
        Cells(i + 1, "H") = Cells(i, "H") + Cells(i - 1, "H")
    End If
    Rows(i).Delete
    Rows(i - 1).Delete
Next i

Application.ScreenUpdating = True


Range("A1344").Activate
    
End Sub

Open in new window

Author

Commented:
I included a sample file.  

On store 1, Ill call that default.  The numbers indicate the rows I need to keep, I do some sorting to remove the others.  On store2 in the file you will see that at the bottom I have 25a and 25b.  Those are the only Rows that need to combined.  

The first 20 or so are default, the new one in this case its store 2 is at the bottom of the report; however this needs to be done in a way that can read the data.  There will be more like store 2 in the future and this report will be mixed until some software is updated in each individual store.  Phasing out and into the new format over the next year or two.  

So I need lines 25a and 25b on store 2 to be combined to a new Row labeled Visa/M.C. like store 1 adding the totals of the two lines to the new line.

Thank You!!
Macro-Report-Test-File1.xls

Author

Commented:
I am going to try that code you gave me.  That looks like what I need.
Become a Certified Penetration Testing Engineer

This CPTE Certified Penetration Testing Engineer course covers everything you need to know about becoming a Certified Penetration Testing Engineer. Career Path: Professional roles include Ethical Hackers, Security Consultants, System Administrators, and Chief Security Officers.

Author

Commented:
The logic in what you wrote looks correct to me, But its not working.  

Also, I deleted the header in the sample file.  The Data does start on line 10

Top Expert 2008
Commented:
sorry about that,

try this update.

Sub IDFields()

Dim lastRow As Long, i As Long

Application.ScreenUpdating = False

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 10 To lastRow
    Select Case Cells(i, 5)
        Case "Food-Breakfast"
            Cells(i, "J") = "1"
        Case "Food-A.B."
            Cells(i, "J") = "2"
        Case "Beverage"
            Cells(i, "J") = "3"
        Case "Merchandise"
            Cells(i, "J") = "4"
        Case "Gift Card Sold"
            Cells(i, "J") = "5"
        Case "Gift Card Redeemed"
            Cells(i, "J") = "6"
        Case "Tips Due"
            Cells(i, "J") = "7"
        Case "Carried Over"
            Cells(i, "J") = "8"
        Case "= TOTAL OUTSTANDING"
            Cells(i, "J") = "9"
        Case "Manager Discounts"
            Cells(i, "J") = "10"
        Case "Employee Discounts"
            Cells(i, "J") = "11"
        Case "Senior Discounts"
            Cells(i, "J") = "12"
        Case "Government Discounts"
            Cells(i, "J") = "13"
        Case "Coupon/FSI Discounts"
            Cells(i, "J") = "14"
        Case "Training Discounts"
            Cells(i, "J") = "15"
        Case "B to B Discounts"
            Cells(i, "J") = "16"
        Case "Other Discounts"
            Cells(i, "J") = "17"
        Case "= TOTAL DISCOUNTS"
            Cells(i, "J") = "18"
        Case "House Charge"
            Cells(i, "J") = "19"
        Case "+ Tax Collected"
            Cells(i, "J") = "20"
        Case "Cash"
            Cells(i, "J") = "21"
        Case "Amex"
            Cells(i, "J") = "22"
        Case "Diners / C.B."
            Cells(i, "J") = "23"
        Case "Discover"
            Cells(i, "J") = "24"
        Case "Visa / M.C."
            Cells(i, "J") = "25"
        Case "Visa"
            Cells(i, "J") = "25a"
        Case "MasterCard"
            Cells(i, "J") = "25b"
        Case "- Tips Paid"
            Cells(i, "J") = "26"
        Case "= TOTAL EXPECTED DEPOSIT"
            Cells(i, "J") = "27"
    End Select 'Select Cells(i, 5)
Next i

For i = lastRow To 10 Step -1
    If Cells(i, "J") = "25b" Then
        Rows(i + 1).Insert
        Cells(i + 1, "J") = "25"
        Cells(i + 1, "G") = Cells(i, "G") + Cells(i - 1, "G")
        Cells(i + 1, "H") = Cells(i, "H") + Cells(i - 1, "H")
        Cells(i + 1, "E") = "Visa / M.C."
        Range("A" & i + 1).Resize(1, 4).Value = Range("A" & i).Resize(1, 4).Value
        Rows(i).Delete
        Rows(i - 1).Delete
    End If
Next i

Application.ScreenUpdating = True
End Sub

Open in new window

Author

Commented:
Truly Amazing.   This works great.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial