PDA

View Full Version : Solved: Quite a complicated one...perhaps?



wa1esy
05-18-2010, 07:20 AM
Basically I have a sheet that looks a bit like this:

Column A
Smith John
Smith J
Smith JA
Jones Peter
Jones P

Column B to H
various numbers

Column I
Smith J
Smith J
Smith J
Jones P
Jones P

Essentially I have taken this data out of pubmed and have numerous duplicate rows containing data for the same author, so I want to find the duplicates, insert a row directly underneath and then sum the values in columns B to H in the inserted row. e.g I want Excel to work down column I find the three Smith J values, insert a row underneath the last one and then autosum B to H into this blank row and then highlight it (yellow or whatever). I have over 50000 rows so if I could find a piece of code to do this bit then I would be able to go down the sheet and QA the highlighted results.

I have no VBA experience at all, but everytime I do this task manually I can't help thinking that there must be another way. Will somebody please show me the light. I would be eternally grateful.

Many thanks. : pray2:

lynnnow
05-18-2010, 07:43 AM
Can you post your workbook for an example? It will help in getting a solution faster.

wa1esy
05-18-2010, 08:00 AM
Yes of course. I haven't posted all 50000 lines but a brief selection. There are two tabs Before is how I get the data and after is how I want it to look.

I should also mention that this in on Excel 2007.

Thanks very much.

lynnnow
05-18-2010, 08:22 AM
Sorry mate, I don't have Office 2007 installed here to help you. Someone else is going to have to give your problem a look.

GTO
05-18-2010, 08:25 AM
Here is the OP's atachment as shown at #3, converted to .xls format.

lynnnow
05-18-2010, 08:27 AM
GTO, I've got the file converter installed here, however, the coding may use options that have not used or tested and hence have thrown in the towel. Thanks.

wa1esy
05-18-2010, 08:34 AM
Ah no probs. Thanks very much for having a crack at it.

Much appreciated.

shrivallabha
05-18-2010, 10:44 AM
I saw this thread a little late. Sorry I could not work out the complete solution but here it is
Sub SortAdd()
Dim LastRow As Long

LastRow = Sheets("Before").Range("I65536").End(xlUp).Row

With Sheets("Before")
For i = 2 To LastRow
If .Cells(i, 9) <> .Cells(i + 1, 9) Then
.Cells(i + 1, 10).Value = "Change"
End If
Next

End With
End Sub

This inserts a value "Change" where the row needs to be inserted
Create a module and paste the code. Just insure that the worksheet name remains "Before" for time being.

I'm going on a leave so really could not go further. It was for the first time I could contribute to the forum where I am learning a lot.

I hope it gives you a stepping stone :)

mbarron
05-18-2010, 11:29 AM
You can harness the power of Excel's built in Subtotal functionality.

Because of the coloring method being used, the macro would have to be altered to be used in Excel versions prior to 2007

Sub subTots()
Range("a1").Subtotal groupby:=9, Function:=xlSum, totallist:= _
Array(2, 3, 4, 5, 6, 7, 8), summarybelowdata:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
With Range("A2", Cells.Find("*", searchDirection:=xlPrevious)).SpecialCells(xlCellTypeVisible)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
With .Font
.Bold = False
End With
End With

ActiveSheet.Outline.ShowLevels RowLevels:=3
Range("A2", Cells.SpecialCells(xlCellTypeLastCell)).Copy
Range("a2").PasteSpecial xlPasteValues
Rows(Cells.Find("*", searchDirection:=xlPrevious).Row).Delete
Range("A2").RemoveSubtotal
Range("I:I").Replace What:=" Total", Replacement:=""
End Sub

wa1esy
05-18-2010, 01:11 PM
Oh my good god. It only bloody works!

mbarron, thank you so much. It seems to be working perfectly!

This forum rocks!

Thanks also to everyone else who responded to this. Keep up the good work.

wa1esy
05-18-2010, 01:22 PM
Oh actually hold up on minute. There is one small issue that might actually be simple to resolve, I'm not sure, as I mentioned before I'm a VBA idiot.
Is there a way of leaving the highlighted cells as formulas so that when I review the data I can delete inappropriate rows and the sum will update automatically. Its just that sometimes not all of the names are actually the same, for example J Smith might pull in James Smith and John Smith, and I will need to delete the wrong ones.
Then I can just copy all, paste as values when I'm finished?

mbarron
05-18-2010, 01:40 PM
Comment out the lines as shown below (the green ones). I've left them in the macro in case you want to revert to the original version.
Sub subTots()
Range("a1").Subtotal groupby:=9, Function:=xlSum, totallist:= _
Array(2, 3, 4, 5, 6, 7, 8), summarybelowdata:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
With Range("A2", Cells.Find("*", searchDirection:=xlPrevious)).SpecialCells(xlCellTypeVisible)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
With .Font
.Bold = False
End With
End With

ActiveSheet.Outline.ShowLevels RowLevels:=3
'Range("A2", Cells.SpecialCells(xlCellTypeLastCell)).Copy
'Range("a2").PasteSpecial xlPasteValues
Rows(Cells.Find("*", searchDirection:=xlPrevious).Row).Delete
'Range("A2").RemoveSubtotal
Range("I:I").Replace What:=" Total", Replacement:=""
End Sub

wa1esy
05-18-2010, 02:28 PM
That is absolutely perfect. Thanks so much.

Genius. :bow: