Help if possible.

I'm trying to create a macro that can delete duplicate names and clear
up a tab in excel. For instance the tab has:

Column A Column B

Way to Go 495
Way to Go 495
Way to Go 495
Way to Go 495
Way to Go 495
Way to Go 495
Way to Go 495
Way to Go 495
Subtotal 1500

Moo 10
Moo 10

I would like for it to clean up the extra information by simply just
clearing contents and deleteing columns. For instance, I want the first
entry to stay and the others to go away. The name will always change and
there is more than one name on the tab that I want this to do it to.

For intance I want it to look like this instead:

Column A Column B
Way to Go 495



Subtotal 1500

Moo 10


Any ideas? I tried the macro below but it doesn't seem to be doing
anything.

Code:
Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through.
Windows("DM Report Template.xls").Activate
iListCount = Sheets("DM 01").Range("A4:B500").Rows.Count
Sheets("DM 01").Range("A4:B500").Select
' Loop until end of records.
Do Until ActiveCell = ""
' Loop through records.
For iCtr = 2 To iListCount
' Don't compare against yourself.
' To specify a different column, change 2 to the column number.
If ActiveCell.Row <> Sheets("DM 01").Cells(iCtr, 2).Row Then
' Do comparison of next record.
If ActiveCell.Value = Sheets("DM 01").Cells(iCtr, 2).Value Then
' If match is true then clear contents on row.
Sheets("DM 01").Cells(iCtr, 2).ClearContents
' Increment counter to account for deleted row.
iCtr = iCtr + 1
End If
End If
Next iCtr
' Go to next record.
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

-----

Thanks, Kelly




*** Sent via Developersdex http://www.developersdex.com ***

Kelly,
1. Do you want to just clear the contents of the duplicate rows, leaving
the rows blank, or do you want to delete the duplicagte cells in columns A
and B, or do you want to delete the entire row?
2. Did you put in the Subtotal row, or have Excel do it for you?
3. After the duplicates are removed, you want to keep the subtotal as it
was when all the duplicates were there, right?
4. Is the data sorted so that like items appear together (Way to Go lines
together, then Moo rows together, etc.)?
James
"Kelly Simcik" <(E-Mail Removed)> wrote in message
news:%(E-Mail Removed)...
> Help if possible.
>
> I'm trying to create a macro that can delete duplicate names and clear
> up a tab in excel. For instance the tab has:
>
> Column A Column B
>
> Way to Go 495
> Way to Go 495
> Way to Go 495
> Way to Go 495
> Way to Go 495
> Way to Go 495
> Way to Go 495
> Way to Go 495
> Subtotal 1500
>
> Moo 10
> Moo 10
>
> I would like for it to clean up the extra information by simply just
> clearing contents and deleteing columns. For instance, I want the first
> entry to stay and the others to go away. The name will always change and
> there is more than one name on the tab that I want this to do it to.
>
> For intance I want it to look like this instead:
>
> Column A Column B
> Way to Go 495
>
>
>
> Subtotal 1500
>
> Moo 10
>
>
> Any ideas? I tried the macro below but it doesn't seem to be doing
> anything.
>
> Code:
> Sub DelDups_OneList()
> Dim iListCount As Integer
> Dim iCtr As Integer
>
> ' Turn off screen updating to speed up macro.
> Application.ScreenUpdating = False
>
> ' Get count of records to search through.
> Windows("DM Report Template.xls").Activate
> iListCount = Sheets("DM 01").Range("A4:B500").Rows.Count
> Sheets("DM 01").Range("A4:B500").Select
> ' Loop until end of records.
> Do Until ActiveCell = ""
> ' Loop through records.
> For iCtr = 2 To iListCount
> ' Don't compare against yourself.
> ' To specify a different column, change 2 to the column number.
> If ActiveCell.Row <> Sheets("DM 01").Cells(iCtr, 2).Row Then
> ' Do comparison of next record.
> If ActiveCell.Value = Sheets("DM 01").Cells(iCtr, 2).Value Then
> ' If match is true then clear contents on row.
> Sheets("DM 01").Cells(iCtr, 2).ClearContents
> ' Increment counter to account for deleted row.
> iCtr = iCtr + 1
> End If
> End If
> Next iCtr
> ' Go to next record.
> ActiveCell.Offset(1, 0).Select
> Loop
> Application.ScreenUpdating = True
> MsgBox "Done!"
> End Sub
>
> -----
>
> Thanks, Kelly
>
>
>
>
> *** Sent via Developersdex http://www.developersdex.com ***

Reply

1. I'd like to clear the contents of just duplicates in columns a and
b, unless the word equals = subtotal. Then, I want it to stay the same
(forgot to mention that).

2. The subtotal row is already there.

3. And, Yes.

4. The data isn't sorted it is already just grouped together when I open
up the raw data.

Any ideas James?

Thanks,

Kelly

*** Sent via Developersdex http://www.developersdex.com ***

Oh, I also forgot to mention that I'd like for this macro to leave the
first entry of the name and delete all duplicates except the word
subtotal for columns a and b.

Thanks,

Kelly



*** Sent via Developersdex http://www.developersdex.com ***

Well, Kelly, it really depends on whether you used Data|Subtotal to put in
the subtotals or whether the subtotals were just put in with a formula. Do
you have an extra gray column on the left with bracket-looking things? That
would mean Excel put in the subtotals.

"Kelly Simcik" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> Oh, I also forgot to mention that I'd like for this macro to leave the
> first entry of the name and delete all duplicates except the word
> subtotal for columns a and b.
>
> Thanks,
>
> Kelly
>
>
>
> *** Sent via Developersdex http://www.developersdex.com ***

The subtotals are there already. Basically this information is pulled
from a webbased program that already has all of the information. So,
the subtotals aren't added by excel.


*** Sent via Developersdex http://www.developersdex.com ***

There is another macro that was written in 2003 by someone else that is
supposed to take out these duplicates. But, for some reason the macro
doesn't get all of them. Is there anyway that I can just edit this
macro to have it do it for me? If so, then I won't have to worry about
writing my own. This macro does other stuff too, but it also takes out
duplicates. Any idea in what portion it would be edited to take out the
rest of the duplicates?

'Option Explicit 'Inserted by OfficeConverter 8.0.0 on line 1
Public Sub formatDriver(strReportType As String)

' formatDriver Driver program for formating reports

Dim ColNm1 As String
Dim SearchStr1 As String
Dim ActiveColumns As Long
Dim SubtotalCol As Long
Dim StartRow_ID As Long
Dim StartCol_ID As Long
Dim EndRow_ID As Long
Dim EndCol_ID As Long
Dim HeadingRange As Variant

' Variables required to handle the removal of duplicate cells
' Duplicate cells will exist if we do a grouping in an EICC report
' that results in multiple records per group.
Dim StartResultsRID As Long
Dim StartRCol_ID As Long

Dim SS1 As Long
Dim SS2 As Long
Dim SS2P As Long
Dim ER1(1 To 3, 1 To 50) As Variant
Dim ER2(1 To 3, 1 To 50) As Variant
Dim ER3(1 To 3, 1 To 50) As Variant
Dim StartofMeasureCol As Long
Dim CompareColEnd As Long
Dim CompareColEndP As Long
Dim CompareRowEnd As Long

'Variables for page adjust scale size and adjustment font size
'***Currently only used for pageBreak Report.
Dim scaleSize As Long
Dim fontSize As Long


Dim Match As String
Dim m As Long
Dim Match2 As String
Dim MatchandCLear As String

' Code block to Bold Heading Section
Call BoldHeading

' Code block to Label sheet as being equal to the name of the file
ActiveSheet.Name = Mid(ActiveWorkbook.Name, 1, 30)

' Code block to Select all records above the current row and delete
them
' These is default text EICC generates regarding the filters used
etc.
' This is not required for the final reporting
' Range(ActiveCell, ActiveCell.End(xlUp)).EntireRow.Select
Range(ActiveCell.End(xlUp),
ActiveCell.End(xlUp).End(xlUp)).EntireRow.Select
Selection.Delete Shift:=xlUp

If strReportType = "pageBreak" Then
scaleSize = 55
fontSize = 10 'twk 12-9-03 at Vicki's request changed from 12 to
10
' Call function to set page size to 60%
Call adjustPageFormat(scaleSize)
' Call function to set font size to [fontSize](12 or 10)
Call adjustPageFont(fontSize)
'Delete the total line
Call RemoveTotals
End If

' Code Block to AutoFit and Wrap text on all columns
Cells.Select
Cells.EntireColumn.AutoFit
Cells.VerticalAlignment = xlTop
Selection.WrapText = True

' Code block to handle the removal of sub-totals
' First it calls a function NbrActiveColumns to
' determine the number of active columns
ActiveColumns = NbrActiveColumns


'Call function to autoformat cells in the entire excel spreadsheet
'Call AutoFrmtCol

' Call function to run through all active columns and
'remove records that include the text 'subtotals' from the excel
spreadsheet

' This if else statement is used to determine which column to start
removing duplicates
' For 2 specific reports (Report 16 - DM.xls, Report 48 - Open
Request.xls
' need the subtotal for the first attribute hence the code should
start
' removing duplicates from the 3rd column onwards (i.e.
SubtotalCol=3)
If strReportType = "subTotals" Or strReportType = "subTotPB" _
Or strReportType = "sort_subTot_PB" Or strReportType =
"subTotal_RC" Then
SubtotalCol = 3
SearchStr1 = "Subtotal"
Else:
SearchStr1 = "Subtotal"
SubtotalCol = 2
End If


Do While SubtotalCol < ActiveColumns
If SubtotalCol = 1 Then
ColNm1 = "A"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
ElseIf SubtotalCol = 2 Then
ColNm1 = "B"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
ElseIf SubtotalCol = 3 Then
ColNm1 = "C"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
ElseIf SubtotalCol = 4 Then
ColNm1 = "D"
If strReportType = "pageBreak" Then
Call RemoveSubtotalwPageBreak(ColNm1, SearchStr1,
ActiveColumns, SubtotalCol)
Else: Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
End If
ElseIf SubtotalCol = 5 Then
ColNm1 = "E"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
ElseIf SubtotalCol = 6 Then
ColNm1 = "F"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
ElseIf SubtotalCol = 7 Then
ColNm1 = "G"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
ElseIf SubtotalCol = 8 Then
ColNm1 = "H"
Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
SubtotalCol)
End If
SubtotalCol = SubtotalCol + 1
Loop


' Code block does the final formatting of the report.
' Adds border around the table
' Adds Color to the Column Headings

Cells(1, "A").Select

Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.Offset(-1, 0).Select
StartRow_ID = ActiveCell.Row
StartCol_ID = ActiveCell.Column

ActiveCell.Offset(1, 0).Select
ActiveCell.End(xlDown).Select
EndRow_ID = ActiveCell.Row
ActiveCell.End(xlToRight).Select
EndCol_ID = ActiveCell.Column

With Range(Cells(StartRow_ID, StartCol_ID), Cells(StartRow_ID + 1,
EndCol_ID))
.BorderAround Weight:=xlMedium
.Interior.ColorIndex = 28
End With

Cells(StartRow_ID, StartCol_ID).EntireRow.Select
Range(Selection, Selection.Offset(1, 0)).EntireRow.Select

With ActiveSheet.PageSetup
.PrintTitleRows = Selection.Address ' Set rows for repeating
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.Orientation = xlLandscape ' Default page set up should be
landscape
End With

'Block Code to perform sort. Currently sort on first column - If
' we want to sort by another column then we just need to add it
here.
If strReportType = "sort_subTot_PB" Then
Call sortAsc(StartCol_ID)
End If

'Block Code to add correct formulas to subtotals and totals
If strReportType = "subTotals" Or strReportType = "subTotPB" _
Or strReportType = "sort_subTot_PB" Then
Call CalcSubtotal(EndCol_ID, strReportType)
ElseIf strReportType = "subTotal_RC" Then
Call CalcSubtotalRC(EndCol_ID, strReportType)
ElseIf strReportType = "regular" Then
Call VerifyTotals(EndCol_ID)
End If

' Block code to remove duplicate records
' The requirements for removing duplicates in an eicc generated
report is the following
' Take the first record and place each cell into an array (ER1)
' Take the second record and place each cell into an array (ER2)
' Compare each cell in the first array (ER1) with each cell in the
second array (ER2)
' If there is a match, place the value into the 3rd array (ER3)
' Once the comparison has been done, clear each cell identified in
the 3rd array
' If there is not a match, move to the next row. This next row
because the starting array
' and is placed into ER1. Again this process starts again where ER1
is compared
' with ER2.


' Start by selecting the cell at the start of the report (ie. upper
border of the report)
Cells(StartRow_ID, StartCol_ID).Select

' Move down until the first non-bold cell is found
' This indicates the start of the data cells
Do While ActiveCell.Font.Bold = True
ActiveCell.Offset(1, 0).Select
Loop

' set StartResults Cells to be the active row
StartResultsRID = ActiveCell.Row

' Set variables to start search
SS1 = StartResultsRID
SS2 = StartResultsRID + 1
SS2P = SS2


'Code block to determine the start of the measures column
StartofMeasureCol = StartCol_ID
Cells(1, "A").Select
ActiveCell.Offset(StartRow_ID - 1, Start_ColID).Select

' block code to determine the column number at which the measures
begin.
' Note: we do not want measures to be included when we analyze
duplicates

Do While IsEmpty(ActiveCell)
If ActiveCell(Column) <= ActiveColumns Then
ActiveCell.Offset(0, 1).Select
StartofMeasureCol = StartofMeasureCol + 1
End If
Loop


' start at cell 1,A and move down to the start of the data cells
Cells(1, "A").Select
ActiveCell.Offset(StartResultsRID - 1, Start_ColID).Select

Dim r As Long ' used in for loop for starting row
Dim rr As Long ' used in loop for comparison row
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim pageBreak As Boolean

' For Each Cell In Range(StartRow_ID, EndRow_ID)

' CompareRowEnd = 1

For r = 1 To EndRow_ID
CompareColEnd = ActiveColumns


If r > 1 Then
SS1 = CompareRowEnd
SS2 = SS1 + 1
SS2P = SS2 + 1
Cells(SS1, StartCol_ID).Select

Else
Cells(SS1, StartCol_ID).Select ' go to the start of the
results section: startresultsId
End If

' place initial value of row, rowid, and colid into array
For i = 1 To StartofMeasureCol
ER1(1, i) = ActiveCell.Value
ER1(2, i) = ActiveCell.Row
ER1(3, i) = ActiveCell.Column
ActiveCell.Offset(0, 1).Select
Next i

For rr = 1 To EndRow_ID
If rr > 1 Then
Cells(SS2P + 1, StartCol_ID).Select
Else
Cells(SS2, StartCol_ID).Select
End If

' place value of row, rowid, and colid into array
For j = 1 To StartofMeasureCol
ER2(1, j) = ActiveCell.Value
ER2(2, j) = ActiveCell.Row
ER2(3, j) = ActiveCell.Column
ActiveCell.Offset(0, 1).Select
Next j

' Clear out array ER3
For m = 1 To StartofMeasureCol
ER3(1, m) = ""
ER3(2, m) = 0
ER3(3, m) = 0
Next m


For k = 1 To StartofMeasureCol
If (ER1(1, k) = ER2(1, k) And ER2(3, k) < CompareColEnd) Then
If ER1(3, k) < StartofMeasureCol Then
ER3(1, k) = ER2(1, k)
ER3(2, k) = ER2(2, k)
ER3(3, k) = ER2(3, k)
Match = "True"
SS2P = ER2(2, k)
End If

Else:
Match = "False"
If rr = 1 Then
If ER2(3, k) > CompareColEndP Then
CompareColEndP = ER2(3, k)
CompareColEnd = ER2(3, k)
CompareRowEnd = ER2(2, k)
Else
CompareColEnd = ER2(3, k)
CompareRowEnd = ER2(2, k)

End If

Else
CompareColEnd = ER2(3, k)
CompareRowEnd = ER2(2, k)
End If



For l = 1 To k - 1

If CompareColEnd = CompareColEndP Then

If l = k - 1 Then
If ER3(1, l + 1) = "" Then
Cells(ER3(2, l), ER3(3, l)).Select
pageBreak = Check_PageBreak
If pageBreak = False Then
Selection.Clear
End If
End If
Else
Cells(ER3(2, l), ER3(3, l)).Select
pageBreak = Check_PageBreak
If pageBreak = False Then
Selection.Clear
End If
End If
Else

l = k - 1
rr = EndRow_ID

End If

Next l
k = ActiveColumns
End If


Next k

If Match = "False" And CompareColEnd = 1 Then
rr = EndRow_ID
End If
Next rr
If CompareRowEnd > EndRow_ID Then
r = EndRow_ID
End If

Next r

' re-border after clearing duplicates
With Range(Cells(StartRow_ID, StartCol_ID), Cells(StartRow_ID + 1,
EndCol_ID))
.BorderAround Weight:=xlMedium
.Interior.ColorIndex = 28
End With

' Code Block to AutoFit and Wrap text on all columns
'- Needs to be run twice to fit everything correctly.
Cells.Select
Cells.EntireColumn.AutoFit
Cells.VerticalAlignment = xlTop
Selection.WrapText = True

'Call function to autoformat 'Journal' cells an exact size
Call AutoFrmtCol

If strReportType = "subTotal_RC" Or strReportType = "pageBreak" Then
'Remove number or requests columnm
Call RemoveNbrRequests
End If

Cells(1, "A").Select

End Sub
' Block of code used to autoformat all cells in the spreadsheet
Public Function AutoFrmtCol()

Dim foundText As Range

Cells(1, "A").Select

Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop

Do While Not IsEmpty(ActiveCell)
'Initlize variables.
If InStr(1, ActiveCell, "Journal") Then
ActiveCell.EntireColumn.ColumnWidth = 75
End If
'Set to the next active cell
ActiveCell.Offset(0, 1).Select
Loop

End Function
' Code block to Bold Heading Section
Public Function BoldHeading()
Cells(1, "A").Select
Range(ActiveCell.End(xlDown).End(xlDown),
ActiveCell.End(xlDown).End(xlDown)).Select
Range(ActiveCell, ActiveCell.Offset(-1, 0)).EntireRow.Select
Selection.Font.Bold = True
End Function
' Code block to adjust page to (adjScaleSize)% for printing purposes.
Public Sub adjustPageFormat(adjScaleSize As Variant) 'Replaced by
OfficeConverter 8.0.0 on line 418 ' original = Public Sub
adjustPageFormat(adjScaleSize)
Cells.Select
With ActiveSheet.PageSetup
.Zoom = adjScaleSize
End With
End Sub
' Code block to adjust page font to size adjFontSize.
Public Sub adjustPageFont(adjFontSize As Variant) 'Replaced by
OfficeConverter 8.0.0 on line 425 ' original = Public Sub
adjustPageFont(adjFontSize)
Cells.Select
With Selection.Font
.Size = adjFontSize
End With
End Sub
Public Sub RemoveSubtotalwPageBreak(ColNm1 As Variant, SearchStr1 As
Variant, ActiveColumns As Variant, SubtotalCol As Variant) 'Replaced by
OfficeConverter 8.0.0 on line 431 ' original = Public Sub
RemoveSubtotalwPageBreak(ColNm1, SearchStr1, ActiveColumns, SubtotalCol)
'twk 12-9-03 Added date column formatting code
' A bug in Analytic Services causes date fields to be formatted
incorrectly.
' To address that, this additional code forces the formatting of date
columns to m/d/yyyy.
' The only way to tell which column is a date is too look for the column
header
' containing the text "date". If the heading exist contain date such as
"Open Date" or
' "Close Date" assume the column is a date column.


Dim RowSelectwPB As String
Dim CntFoundFirstBoldwPB As Long
Dim LastStringColwPB As Long

Dim DateColumn As Boolean
DateColumn = False

Cells(1, ColNm1).Select

Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop

Do While Not IsEmpty(ActiveCell)

'twk Once we find a date header we can start formatting for date
If InStr(1, ActiveCell, "date", 1) Then DateColumn = True
If DateColumn Then ActiveCell.NumberFormat = "m/d/yy"

ActiveCell.Offset(1, 0).Select

If ActiveCell = "Subtotal" Then
Selection.EntireRow.Delete Shift:=xlUp
ActiveSheet.HPageBreaks.Add Before:=ActiveCell
End If
Loop

End Sub
Public Function Check_PageBreak()

Dim i As Long, BreakType As Long

' To check for a vertical page break, use the EntireColumn property.
BreakType = ActiveCell.EntireRow.pageBreak

If BreakType = xlAutomatic Or BreakType = xlManual Then
' Enter the code that you want to run if the current row
' contains an automatic page break.
'MsgBox "There is an automatic page break above this row"
'ElseIf BreakType = xlManual Then
' Enter the code that you want to run if the current row
' contains a manual page break.
'MsgBox "There is a manual page break above this row"
Check_PageBreak = True
Else
' Enter the code that you want to run if the current row
' does not contain a page break.
'MsgBox "There is no page break above this row"
Check_PageBreak = False
End If

End Function



*** Sent via Developersdex http://www.developersdex.com ***

So, you have the extra gray column on the left with the bracket-looking
things?

"Kelly Simcik" <(E-Mail Removed)> wrote in message
news:%(E-Mail Removed)...
> There is another macro that was written in 2003 by someone else that is
> supposed to take out these duplicates. But, for some reason the macro
> doesn't get all of them. Is there anyway that I can just edit this
> macro to have it do it for me? If so, then I won't have to worry about
> writing my own. This macro does other stuff too, but it also takes out
> duplicates. Any idea in what portion it would be edited to take out the
> rest of the duplicates?
>
> 'Option Explicit 'Inserted by OfficeConverter 8.0.0 on line 1
> Public Sub formatDriver(strReportType As String)
>
> ' formatDriver Driver program for formating reports
>
> Dim ColNm1 As String
> Dim SearchStr1 As String
> Dim ActiveColumns As Long
> Dim SubtotalCol As Long
> Dim StartRow_ID As Long
> Dim StartCol_ID As Long
> Dim EndRow_ID As Long
> Dim EndCol_ID As Long
> Dim HeadingRange As Variant
>
> ' Variables required to handle the removal of duplicate cells
> ' Duplicate cells will exist if we do a grouping in an EICC report
> ' that results in multiple records per group.
> Dim StartResultsRID As Long
> Dim StartRCol_ID As Long
>
> Dim SS1 As Long
> Dim SS2 As Long
> Dim SS2P As Long
> Dim ER1(1 To 3, 1 To 50) As Variant
> Dim ER2(1 To 3, 1 To 50) As Variant
> Dim ER3(1 To 3, 1 To 50) As Variant
> Dim StartofMeasureCol As Long
> Dim CompareColEnd As Long
> Dim CompareColEndP As Long
> Dim CompareRowEnd As Long
>
> 'Variables for page adjust scale size and adjustment font size
> '***Currently only used for pageBreak Report.
> Dim scaleSize As Long
> Dim fontSize As Long
>
>
> Dim Match As String
> Dim m As Long
> Dim Match2 As String
> Dim MatchandCLear As String
>
> ' Code block to Bold Heading Section
> Call BoldHeading
>
> ' Code block to Label sheet as being equal to the name of the file
> ActiveSheet.Name = Mid(ActiveWorkbook.Name, 1, 30)
>
> ' Code block to Select all records above the current row and delete
> them
> ' These is default text EICC generates regarding the filters used
> etc.
> ' This is not required for the final reporting
> ' Range(ActiveCell, ActiveCell.End(xlUp)).EntireRow.Select
> Range(ActiveCell.End(xlUp),
> ActiveCell.End(xlUp).End(xlUp)).EntireRow.Select
> Selection.Delete Shift:=xlUp
>
> If strReportType = "pageBreak" Then
> scaleSize = 55
> fontSize = 10 'twk 12-9-03 at Vicki's request changed from 12 to
> 10
> ' Call function to set page size to 60%
> Call adjustPageFormat(scaleSize)
> ' Call function to set font size to [fontSize](12 or 10)
> Call adjustPageFont(fontSize)
> 'Delete the total line
> Call RemoveTotals
> End If
>
> ' Code Block to AutoFit and Wrap text on all columns
> Cells.Select
> Cells.EntireColumn.AutoFit
> Cells.VerticalAlignment = xlTop
> Selection.WrapText = True
>
> ' Code block to handle the removal of sub-totals
> ' First it calls a function NbrActiveColumns to
> ' determine the number of active columns
> ActiveColumns = NbrActiveColumns
>
>
> 'Call function to autoformat cells in the entire excel spreadsheet
> 'Call AutoFrmtCol
>
> ' Call function to run through all active columns and
> 'remove records that include the text 'subtotals' from the excel
> spreadsheet
>
> ' This if else statement is used to determine which column to start
> removing duplicates
> ' For 2 specific reports (Report 16 - DM.xls, Report 48 - Open
> Request.xls
> ' need the subtotal for the first attribute hence the code should
> start
> ' removing duplicates from the 3rd column onwards (i.e.
> SubtotalCol=3)
> If strReportType = "subTotals" Or strReportType = "subTotPB" _
> Or strReportType = "sort_subTot_PB" Or strReportType =
> "subTotal_RC" Then
> SubtotalCol = 3
> SearchStr1 = "Subtotal"
> Else:
> SearchStr1 = "Subtotal"
> SubtotalCol = 2
> End If
>
>
> Do While SubtotalCol < ActiveColumns
> If SubtotalCol = 1 Then
> ColNm1 = "A"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> ElseIf SubtotalCol = 2 Then
> ColNm1 = "B"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> ElseIf SubtotalCol = 3 Then
> ColNm1 = "C"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> ElseIf SubtotalCol = 4 Then
> ColNm1 = "D"
> If strReportType = "pageBreak" Then
> Call RemoveSubtotalwPageBreak(ColNm1, SearchStr1,
> ActiveColumns, SubtotalCol)
> Else: Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> End If
> ElseIf SubtotalCol = 5 Then
> ColNm1 = "E"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> ElseIf SubtotalCol = 6 Then
> ColNm1 = "F"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> ElseIf SubtotalCol = 7 Then
> ColNm1 = "G"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> ElseIf SubtotalCol = 8 Then
> ColNm1 = "H"
> Call RemoveSubtotal(ColNm1, SearchStr1, ActiveColumns,
> SubtotalCol)
> End If
> SubtotalCol = SubtotalCol + 1
> Loop
>
>
> ' Code block does the final formatting of the report.
> ' Adds border around the table
> ' Adds Color to the Column Headings
>
> Cells(1, "A").Select
>
> Do While IsEmpty(ActiveCell)
> ActiveCell.Offset(1, 0).Select
> Loop
>
> ActiveCell.Offset(-1, 0).Select
> StartRow_ID = ActiveCell.Row
> StartCol_ID = ActiveCell.Column
>
> ActiveCell.Offset(1, 0).Select
> ActiveCell.End(xlDown).Select
> EndRow_ID = ActiveCell.Row
> ActiveCell.End(xlToRight).Select
> EndCol_ID = ActiveCell.Column
>
> With Range(Cells(StartRow_ID, StartCol_ID), Cells(StartRow_ID + 1,
> EndCol_ID))
> .BorderAround Weight:=xlMedium
> .Interior.ColorIndex = 28
> End With
>
> Cells(StartRow_ID, StartCol_ID).EntireRow.Select
> Range(Selection, Selection.Offset(1, 0)).EntireRow.Select
>
> With ActiveSheet.PageSetup
> .PrintTitleRows = Selection.Address ' Set rows for repeating
> .PrintTitleColumns = ""
> End With
> ActiveSheet.PageSetup.PrintArea = ""
> With ActiveSheet.PageSetup
> .Orientation = xlLandscape ' Default page set up should be
> landscape
> End With
>
> 'Block Code to perform sort. Currently sort on first column - If
> ' we want to sort by another column then we just need to add it
> here.
> If strReportType = "sort_subTot_PB" Then
> Call sortAsc(StartCol_ID)
> End If
>
> 'Block Code to add correct formulas to subtotals and totals
> If strReportType = "subTotals" Or strReportType = "subTotPB" _
> Or strReportType = "sort_subTot_PB" Then
> Call CalcSubtotal(EndCol_ID, strReportType)
> ElseIf strReportType = "subTotal_RC" Then
> Call CalcSubtotalRC(EndCol_ID, strReportType)
> ElseIf strReportType = "regular" Then
> Call VerifyTotals(EndCol_ID)
> End If
>
> ' Block code to remove duplicate records
> ' The requirements for removing duplicates in an eicc generated
> report is the following
> ' Take the first record and place each cell into an array (ER1)
> ' Take the second record and place each cell into an array (ER2)
> ' Compare each cell in the first array (ER1) with each cell in the
> second array (ER2)
> ' If there is a match, place the value into the 3rd array (ER3)
> ' Once the comparison has been done, clear each cell identified in
> the 3rd array
> ' If there is not a match, move to the next row. This next row
> because the starting array
> ' and is placed into ER1. Again this process starts again where ER1
> is compared
> ' with ER2.
>
>
> ' Start by selecting the cell at the start of the report (ie. upper
> border of the report)
> Cells(StartRow_ID, StartCol_ID).Select
>
> ' Move down until the first non-bold cell is found
> ' This indicates the start of the data cells
> Do While ActiveCell.Font.Bold = True
> ActiveCell.Offset(1, 0).Select
> Loop
>
> ' set StartResults Cells to be the active row
> StartResultsRID = ActiveCell.Row
>
> ' Set variables to start search
> SS1 = StartResultsRID
> SS2 = StartResultsRID + 1
> SS2P = SS2
>
>
> 'Code block to determine the start of the measures column
> StartofMeasureCol = StartCol_ID
> Cells(1, "A").Select
> ActiveCell.Offset(StartRow_ID - 1, Start_ColID).Select
>
> ' block code to determine the column number at which the measures
> begin.
> ' Note: we do not want measures to be included when we analyze
> duplicates
>
> Do While IsEmpty(ActiveCell)
> If ActiveCell(Column) <= ActiveColumns Then
> ActiveCell.Offset(0, 1).Select
> StartofMeasureCol = StartofMeasureCol + 1
> End If
> Loop
>
>
> ' start at cell 1,A and move down to the start of the data cells
> Cells(1, "A").Select
> ActiveCell.Offset(StartResultsRID - 1, Start_ColID).Select
>
> Dim r As Long ' used in for loop for starting row
> Dim rr As Long ' used in loop for comparison row
> Dim i As Long
> Dim j As Long
> Dim k As Long
> Dim l As Long
> Dim pageBreak As Boolean
>
> ' For Each Cell In Range(StartRow_ID, EndRow_ID)
>
> ' CompareRowEnd = 1
>
> For r = 1 To EndRow_ID
> CompareColEnd = ActiveColumns
>
>
> If r > 1 Then
> SS1 = CompareRowEnd
> SS2 = SS1 + 1
> SS2P = SS2 + 1
> Cells(SS1, StartCol_ID).Select
>
> Else
> Cells(SS1, StartCol_ID).Select ' go to the start of the
> results section: startresultsId
> End If
>
> ' place initial value of row, rowid, and colid into array
> For i = 1 To StartofMeasureCol
> ER1(1, i) = ActiveCell.Value
> ER1(2, i) = ActiveCell.Row
> ER1(3, i) = ActiveCell.Column
> ActiveCell.Offset(0, 1).Select
> Next i
>
> For rr = 1 To EndRow_ID
> If rr > 1 Then
> Cells(SS2P + 1, StartCol_ID).Select
> Else
> Cells(SS2, StartCol_ID).Select
> End If
>
> ' place value of row, rowid, and colid into array
> For j = 1 To StartofMeasureCol
> ER2(1, j) = ActiveCell.Value
> ER2(2, j) = ActiveCell.Row
> ER2(3, j) = ActiveCell.Column
> ActiveCell.Offset(0, 1).Select
> Next j
>
> ' Clear out array ER3
> For m = 1 To StartofMeasureCol
> ER3(1, m) = ""
> ER3(2, m) = 0
> ER3(3, m) = 0
> Next m
>
>
> For k = 1 To StartofMeasureCol
> If (ER1(1, k) = ER2(1, k) And ER2(3, k) < CompareColEnd) Then
> If ER1(3, k) < StartofMeasureCol Then
> ER3(1, k) = ER2(1, k)
> ER3(2, k) = ER2(2, k)
> ER3(3, k) = ER2(3, k)
> Match = "True"
> SS2P = ER2(2, k)
> End If
>
> Else:
> Match = "False"
> If rr = 1 Then
> If ER2(3, k) > CompareColEndP Then
> CompareColEndP = ER2(3, k)
> CompareColEnd = ER2(3, k)
> CompareRowEnd = ER2(2, k)
> Else
> CompareColEnd = ER2(3, k)
> CompareRowEnd = ER2(2, k)
>
> End If
>
> Else
> CompareColEnd = ER2(3, k)
> CompareRowEnd = ER2(2, k)
> End If
>
>
>
> For l = 1 To k - 1
>
> If CompareColEnd = CompareColEndP Then
>
> If l = k - 1 Then
> If ER3(1, l + 1) = "" Then
> Cells(ER3(2, l), ER3(3, l)).Select
> pageBreak = Check_PageBreak
> If pageBreak = False Then
> Selection.Clear
> End If
> End If
> Else
> Cells(ER3(2, l), ER3(3, l)).Select
> pageBreak = Check_PageBreak
> If pageBreak = False Then
> Selection.Clear
> End If
> End If
> Else
>
> l = k - 1
> rr = EndRow_ID
>
> End If
>
> Next l
> k = ActiveColumns
> End If
>
>
> Next k
>
> If Match = "False" And CompareColEnd = 1 Then
> rr = EndRow_ID
> End If
> Next rr
> If CompareRowEnd > EndRow_ID Then
> r = EndRow_ID
> End If
>
> Next r
>
> ' re-border after clearing duplicates
> With Range(Cells(StartRow_ID, StartCol_ID), Cells(StartRow_ID + 1,
> EndCol_ID))
> .BorderAround Weight:=xlMedium
> .Interior.ColorIndex = 28
> End With
>
> ' Code Block to AutoFit and Wrap text on all columns
> '- Needs to be run twice to fit everything correctly.
> Cells.Select
> Cells.EntireColumn.AutoFit
> Cells.VerticalAlignment = xlTop
> Selection.WrapText = True
>
> 'Call function to autoformat 'Journal' cells an exact size
> Call AutoFrmtCol
>
> If strReportType = "subTotal_RC" Or strReportType = "pageBreak" Then
> 'Remove number or requests columnm
> Call RemoveNbrRequests
> End If
>
> Cells(1, "A").Select
>
> End Sub
> ' Block of code used to autoformat all cells in the spreadsheet
> Public Function AutoFrmtCol()
>
> Dim foundText As Range
>
> Cells(1, "A").Select
>
> Do While IsEmpty(ActiveCell)
> ActiveCell.Offset(1, 0).Select
> Loop
>
> Do While Not IsEmpty(ActiveCell)
> 'Initlize variables.
> If InStr(1, ActiveCell, "Journal") Then
> ActiveCell.EntireColumn.ColumnWidth = 75
> End If
> 'Set to the next active cell
> ActiveCell.Offset(0, 1).Select
> Loop
>
> End Function
> ' Code block to Bold Heading Section
> Public Function BoldHeading()
> Cells(1, "A").Select
> Range(ActiveCell.End(xlDown).End(xlDown),
> ActiveCell.End(xlDown).End(xlDown)).Select
> Range(ActiveCell, ActiveCell.Offset(-1, 0)).EntireRow.Select
> Selection.Font.Bold = True
> End Function
> ' Code block to adjust page to (adjScaleSize)% for printing purposes.
> Public Sub adjustPageFormat(adjScaleSize As Variant) 'Replaced by
> OfficeConverter 8.0.0 on line 418 ' original = Public Sub
> adjustPageFormat(adjScaleSize)
> Cells.Select
> With ActiveSheet.PageSetup
> .Zoom = adjScaleSize
> End With
> End Sub
> ' Code block to adjust page font to size adjFontSize.
> Public Sub adjustPageFont(adjFontSize As Variant) 'Replaced by
> OfficeConverter 8.0.0 on line 425 ' original = Public Sub
> adjustPageFont(adjFontSize)
> Cells.Select
> With Selection.Font
> .Size = adjFontSize
> End With
> End Sub
> Public Sub RemoveSubtotalwPageBreak(ColNm1 As Variant, SearchStr1 As
> Variant, ActiveColumns As Variant, SubtotalCol As Variant) 'Replaced by
> OfficeConverter 8.0.0 on line 431 ' original = Public Sub
> RemoveSubtotalwPageBreak(ColNm1, SearchStr1, ActiveColumns, SubtotalCol)
> 'twk 12-9-03 Added date column formatting code
> ' A bug in Analytic Services causes date fields to be formatted
> incorrectly.
> ' To address that, this additional code forces the formatting of date
> columns to m/d/yyyy.
> ' The only way to tell which column is a date is too look for the column
> header
> ' containing the text "date". If the heading exist contain date such as
> "Open Date" or
> ' "Close Date" assume the column is a date column.
>
>
> Dim RowSelectwPB As String
> Dim CntFoundFirstBoldwPB As Long
> Dim LastStringColwPB As Long
>
> Dim DateColumn As Boolean
> DateColumn = False
>
> Cells(1, ColNm1).Select
>
> Do While IsEmpty(ActiveCell)
> ActiveCell.Offset(1, 0).Select
> Loop
>
> Do While Not IsEmpty(ActiveCell)
>
> 'twk Once we find a date header we can start formatting for date
> If InStr(1, ActiveCell, "date", 1) Then DateColumn = True
> If DateColumn Then ActiveCell.NumberFormat = "m/d/yy"
>
> ActiveCell.Offset(1, 0).Select
>
> If ActiveCell = "Subtotal" Then
> Selection.EntireRow.Delete Shift:=xlUp
> ActiveSheet.HPageBreaks.Add Before:=ActiveCell
> End If
> Loop
>
> End Sub
> Public Function Check_PageBreak()
>
> Dim i As Long, BreakType As Long
>
> ' To check for a vertical page break, use the EntireColumn property.
> BreakType = ActiveCell.EntireRow.pageBreak
>
> If BreakType = xlAutomatic Or BreakType = xlManual Then
> ' Enter the code that you want to run if the current row
> ' contains an automatic page break.
> 'MsgBox "There is an automatic page break above this row"
> 'ElseIf BreakType = xlManual Then
> ' Enter the code that you want to run if the current row
> ' contains a manual page break.
> 'MsgBox "There is a manual page break above this row"
> Check_PageBreak = True
> Else
> ' Enter the code that you want to run if the current row
> ' does not contain a page break.
> 'MsgBox "There is no page break above this row"
> Check_PageBreak = False
> End If
>
> End Function
>
>
>
> *** Sent via Developersdex http://www.developersdex.com ***

I don't know what you mean by extra bracket? There is no extra bracket
that I can see. Just letting you know. What would it matter?

*** Sent via Developersdex http://www.developersdex.com ***

Kelly, Good. That will make this much easier. I didn't particularly want
to mess with subtotals put in by Excel. I should be able to get back to you
pretty quick with a solution. In the meantime, it would be a good idea to
save a copy of your file in case anything goes awry.
James

"Kelly Simcik" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
>I don't know what you mean by extra bracket? There is no extra bracket
> that I can see. Just letting you know. What would it matter?
>
> *** Sent via Developersdex http://www.developersdex.com ***