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 ***
