Sort Range and Sum/Delete Duplicate Rows

[prkhan56]

Hello All,
I am using Excel 2003 and have the following problem.

We export some data in excel on a regular basis (about 18000+ rows).
Row 9 is the header row
The data range is C10 to P18000 +. The end row will vary.

Cell E5 contains a key word which should be utilized to paste the
Range C10:C18000+ (all active Rows) with the Key word. For eg, if E5
contains the text A then C10:C18000+ should display Account, if E5 = B
then C10:C18000+ should display Balance.

I wish to have a macro which should do the following:

a) Paste the key word as described above.

b) Sort the active data range C1018000+ using Col F (Primary Key -
Ascending) and Col H (Secondary Key – Descending).

b) After Sorting, Sum Col K (for all duplicate rows only) and Remove
Duplicate Rows using Col D to verify duplicate Rows.

Hope someone can help me

Thanks in advance

Rashid Khan

 

[Joel]

Because you have so many lines, it is better to mark the delete lines with
an X. then sort the X's to the top of the file and delete all the rows as a
single group. this code should run in seconds instead of minutes. I used
column IV to put the X for deletion then deleted column IV.

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
LastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("C10:C" & LastRow).Value = Range("E5").Value
Set SortRange = Range("C10" & LastRow)

SortRange.Sort _
Key1:=Range("F10"), _
Order1:=xlAscending, _
Key2:=Range("H10"), _
Order2:=xlDescending, _
Header:=xlGuess

RowCount = 10
Do While Range("D" & RowCount) <> ""
If Range("D" & RowCount) = _
Range("D" & (RowCount + 1)) Then

'Put an x in rows to delete
Range("IV" & RowCount) = "X"
End If
RowCount = RowCount + 1
Loop

'sort the deleted Rows to top of the spreadsheet and then delete these rows
Set SortRange = Range("C10:IV" & LastRow)
SortRange.Sort _
Key1:=Range("IV10"), _
Order1:=xlDescending, _
Header:=xlGuess
LastRow = Range("IV" & Rows.Count).End(xlUp).Row
Rows("10:" & LastRow).Delete
Columns("IV").delete
End Sub

 

[prkhan56]

Because you have so many lines,  it is better to mark the delete lines with
an X.  then sort the X's to the top of the file and delete all the rowsas a
single group.  this code should run in seconds instead of minutes.  Iused
column IV to put the X for deletion then deleted column IV.

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
   LastRow = Range("D" & Rows.Count).End(xlUp).Row
   Range("C10:C" & LastRow).Value = Range("E5").Value
   Set SortRange = Range("C10" & LastRow)

   SortRange.Sort _
       Key1:=Range("F10"), _
       Order1:=xlAscending, _
       Key2:=Range("H10"), _
       Order2:=xlDescending, _
       Header:=xlGuess

   RowCount = 10
   Do While Range("D" & RowCount) <> ""
      If Range("D" & RowCount) = _
         Range("D" & (RowCount + 1)) Then

         'Put an x in rows to delete
         Range("IV" & RowCount) = "X"
      End If
      RowCount = RowCount + 1
   Loop

   'sort the deleted Rows to top of the spreadsheet and then delete these rows
   Set SortRange = Range("C10:IV" & LastRow)
   SortRange.Sort _
       Key1:=Range("IV10"), _
       Order1:=xlDescending, _
       Header:=xlGuess
   LastRow = Range("IV" & Rows.Count).End(xlUp).Row
   Rows("10:" & LastRow).Delete
   Columns("IV").delete
End Sub














- Show quoted text -

Hi Joel,
Thanks for your prompt reply.
I want to Sum Col K which is not done in the macro given by you.
Also Col F should be used to verify the duplicate Rows (by mistake I
mentioned Col D in my previous post)

Thanks for your help once again

Rashid Khan

 

[Joel]

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
LastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("C10:C" & LastRow).Value = Range("E5").Value
Set SortRange = Range("C10" & LastRow)

SortRange.Sort _
Key1:=Range("F10"), _
Order1:=xlAscending, _
Key2:=Range("H10"), _
Order2:=xlDescending, _
Header:=xlGuess

RowCount = 10
Do While Range("F" & RowCount) <> ""
If Range("F" & RowCount) = _
Range("F" & (RowCount + 1)) Then

'Put an x in rows to delete
Range("IV" & RowCount) = "X"
End If
RowCount = RowCount + 1
Loop

'sort the deleted Rows to top of the spreadsheet and then delete these rows
Set SortRange = Range("C10:IV" & LastRow)
SortRange.Sort _
Key1:=Range("IV10"), _
Order1:=xlDescending, _
Header:=xlGuess
LastRow = Range("IV" & Rows.Count).End(xlUp).Row
Rows("10:" & LastRow).Delete
Columns("IV").Delete

'Get Number of rows after duplicates are deleted
LastRow = Range("D" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 2
Range("J" & NewRow) = "TOTAL"
Range("K" & NewRow).Formula = "=SUM(K10:K" & LastRow & ")"

End Sub

 

[prkhan56]

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
   LastRow =Range("D" & Rows.Count).End(xlUp).Row
   Range("C10:C" & LastRow).Value =Range("E5").Value
   Set SortRange =Range("C10" & LastRow)

   SortRange.Sort_
       Key1:=Range("F10"), _
       Order1:=xlAscending, _
       Key2:=Range("H10"), _
       Order2:=xlDescending, _
       Header:=xlGuess

   RowCount = 10
   Do WhileRange("F" & RowCount) <> ""
      IfRange("F" & RowCount) = _
         Range("F" & (RowCount + 1)) Then

         'Put an x in rows to delete
         Range("IV" & RowCount) = "X"
      End If
      RowCount = RowCount + 1
   Loop

   'sortthe deleted Rows to top of the spreadsheet and then delete these rows
   Set SortRange =Range("C10:IV" & LastRow)
   SortRange.Sort_
       Key1:=Range("IV10"), _
       Order1:=xlDescending, _
       Header:=xlGuess
   LastRow =Range("IV" & Rows.Count).End(xlUp).Row
   Rows("10:" & LastRow).Delete
   Columns("IV").Delete

   'Get Number of rows after duplicates are deleted
   LastRow =Range("D" & Rows.Count).End(xlUp).Row
   NewRow = LastRow + 2
   Range("J" & NewRow) = "TOTAL"
   Range("K" & NewRow).Formula = "=SUM(K10:K" & LastRow & ")"

End Sub








- Show quoted text -

Hi Joel,
I am sorry I think I did not explain my problem properly. Please see
below an example showing Before and After results

Before (duplicate rows in Col F with different amounts in Col K)
Col F Col K
Joe Smith $200.00
Joe Smith $300.00
Joe Smith $250.00
Kip Tucker $100.00
Kip Tucker $150.00
Kip Tucker $200.00

After (duplicate rows in Col F are deleted showing Sum of amounts in
Col K)
Joe Smith $750.00
Kip Tucker $450.00

Thanks for you help and time once again.

Rashid Khan

 

[Joel]

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
LastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("C10:C" & LastRow).Value = Range("E5").Value
Set SortRange = Range("C10" & LastRow)

SortRange.Sort _
Key1:=Range("F10"), _
Order1:=xlAscending, _
Key2:=Range("H10"), _
Order2:=xlDescending, _
Header:=xlGuess

RowCount = 10
Do While Range("F" & RowCount) <> ""
If Range("F" & RowCount) = _
Range("F" & (RowCount + 1)) Then

'Put an x in rows to delete
Range("IV" & RowCount) = "X"
'total rows
Range("K" & (RowCount + 1)) = _
Range("K" & (RowCount + 1)) + _
Range("K" & RowCount)

End If
RowCount = RowCount + 1
Loop

'sort the deleted Rows to top of the spreadsheet and then delete these rows
Set SortRange = Range("C10:IV" & LastRow)
SortRange.Sort _
Key1:=Range("IV10"), _
Order1:=xlDescending, _
Header:=xlGuess
LastRow = Range("IV" & Rows.Count).End(xlUp).Row
Rows("10:" & LastRow).Delete
Columns("IV").Delete

'Get Number of rows after duplicates are deleted
LastRow = Range("D" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 2
Range("J" & NewRow) = "TOTAL"
Range("K" & NewRow).Formula = "=SUM(K10:K" & LastRow & ")"

End Sub

 

[prkhan56]

Hi Joel,
The Macro works perfectly but Col H (which are dates) does not give
the desired results.
I want to keep the latest date visible after all the duplicate rows
are deleted. For eg

Col F Col H
AAA 20/1/2007
AAA 20/2/2007
AAA 20/3/2007
...
...
...
the result visible after sort Descending and deletion of duplicate
rows should be

AAA 20/3/2007

Can you suggest something please.

Thanks for all your help and time

Rashid Khan

 

[Joel]

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
LastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("C10:C" & LastRow).Value = Range("E5").Value
Set SortRange = Range("C10" & LastRow)

SortRange.Sort _
Key1:=Range("F10"), _
Order1:=xlAscending, _
Key2:=Range("H10"), _
Order2:=xlDescending, _
Header:=xlGuess

RowCount = 10
Do While Range("F" & RowCount) <> ""
If Range("F" & RowCount) = _
Range("F" & (RowCount + 1)) Then

'Put an x in rows to delete
Range("IV" & RowCount) = "X"
'total rows
Range("K" & (RowCount + 1)) = _
Range("K" & (RowCount + 1)) + _
Range("K" & RowCount)

If Range("H" & (RowCount + 1)) < _
Range("H" & RowCount) Then

Range("H" & (RowCount + 1)) = _
Range("H" & RowCount)
End If
End If
RowCount = RowCount + 1
Loop

'sort the deleted Rows to top of the spreadsheet and then delete these rows
Set SortRange = Range("C10:IV" & LastRow)
SortRange.Sort _
Key1:=Range("IV10"), _
Order1:=xlDescending, _
Header:=xlGuess
LastRow = Range("IV" & Rows.Count).End(xlUp).Row
Rows("10:" & LastRow).Delete
Columns("IV").Delete

'Get Number of rows after duplicates are deleted
LastRow = Range("D" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 2
Range("J" & NewRow) = "TOTAL"
Range("K" & NewRow).Formula = "=SUM(K10:K" & LastRow & ")"

End Sub

 

[prkhan56]

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
   LastRow = Range("D" & Rows.Count).End(xlUp).Row
   Range("C10:C" & LastRow).Value = Range("E5").Value
   Set SortRange = Range("C10" & LastRow)

   SortRange.Sort _
       Key1:=Range("F10"), _
       Order1:=xlAscending, _
       Key2:=Range("H10"), _
       Order2:=xlDescending, _
       Header:=xlGuess

   RowCount = 10
   Do While Range("F" & RowCount) <> ""
      If Range("F" & RowCount) = _
         Range("F" & (RowCount + 1)) Then

         'Put an x in rows to delete
         Range("IV" & RowCount) = "X"
         'total rows
         Range("K" & (RowCount + 1)) = _
            Range("K" & (RowCount + 1)) + _
            Range("K" & RowCount)

         If Range("H" & (RowCount + 1)) < _
            Range("H" & RowCount) Then

            Range("H" & (RowCount + 1)) = _
               Range("H" & RowCount)
         End If
      End If
      RowCount = RowCount + 1
   Loop

   'sort the deleted Rows to top of the spreadsheet and then delete these rows
   Set SortRange = Range("C10:IV" & LastRow)
   SortRange.Sort _
       Key1:=Range("IV10"), _
       Order1:=xlDescending, _
       Header:=xlGuess
   LastRow = Range("IV" & Rows.Count).End(xlUp).Row
   Rows("10:" & LastRow).Delete
   Columns("IV").Delete

   'Get Number of rows after duplicates are deleted
   LastRow = Range("D" & Rows.Count).End(xlUp).Row
   NewRow = LastRow + 2
   Range("J" & NewRow) = "TOTAL"
   Range("K" & NewRow).Formula = "=SUM(K10:K" & LastRow & ")"

End Sub











- Show quoted text -

Thanks a million. Works perfect

Rashid Khan

 

[prkhan56]

Sub ExportData()
'
' Macro1 Macro
' Macro recorded 7/18/2008 by Joel
'

'
   LastRow = Range("D" & Rows.Count).End(xlUp).Row
   Range("C10:C" & LastRow).Value = Range("E5").Value
   Set SortRange = Range("C10" & LastRow)

   SortRange.Sort _
       Key1:=Range("F10"), _
       Order1:=xlAscending, _
       Key2:=Range("H10"), _
       Order2:=xlDescending, _
       Header:=xlGuess

   RowCount = 10
   Do While Range("F" & RowCount) <> ""
      If Range("F" & RowCount) = _
         Range("F" & (RowCount + 1)) Then

         'Put an x in rows to delete
         Range("IV" & RowCount) = "X"
         'total rows
         Range("K" & (RowCount + 1)) = _
            Range("K" & (RowCount + 1)) + _
            Range("K" & RowCount)

         If Range("H" & (RowCount + 1)) < _
            Range("H" & RowCount) Then

            Range("H" & (RowCount + 1)) = _
               Range("H" & RowCount)
         End If
      End If
      RowCount = RowCount + 1
   Loop

   'sort the deleted Rows to top of the spreadsheet and then delete these rows
   Set SortRange = Range("C10:IV" & LastRow)
   SortRange.Sort _
       Key1:=Range("IV10"), _
       Order1:=xlDescending, _
       Header:=xlGuess
   LastRow = Range("IV" & Rows.Count).End(xlUp).Row
   Rows("10:" & LastRow).Delete
   Columns("IV").Delete

   'Get Number of rows after duplicates are deleted
   LastRow = Range("D" & Rows.Count).End(xlUp).Row
   NewRow = LastRow + 2
   Range("J" & NewRow) = "TOTAL"
   Range("K" & NewRow).Formula = "=SUM(K10:K" & LastRow & ")"

End Sub











- Show quoted text -

Thanks a million. Works perfect
Rashid Khan