Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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 *** |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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" wrote in message ... 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 *** |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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 *** |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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 *** |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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" wrote in message ... 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 *** |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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 *** |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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 Befo=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 *** |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
So, you have the extra gray column on the left with the bracket-looking
things? "Kelly Simcik" wrote in message ... 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 Befo=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 *** |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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 *** |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
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" wrote in message ... 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 *** |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
Delete Duplicate Names in Excel (Clear Text)
Kelly, Copy the code below, paste it in a standard module and run it. Note
that it uses whatever sheet is active at the time. The code assumes that row 1 is a heading row and there is nothing beneath the data to be "cleaned up" in columns A and B. Let me know if this works for you! James Sub DupesOut() Dim k As Long For k = Cells(Rows.Count, "a").End(xlUp).Row To 3 Step -1 If InStr(1, Cells(k, "a"), "total", vbTextCompare) 0 Then Cells(k, "b").Formula = Cells(k, "b").Value Else If Cells(k, "a") = Cells(k - 1, "a") Then Cells(k, "a").ClearContents Cells(k, "b").ClearContents End If End If Next k End Sub "Zone" wrote in message ... 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" wrote in message ... 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 *** |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Find Duplicate names and delete problem | Excel Discussion (Misc queries) | |||
Compare 2 columns and delete duplicate text | Excel Worksheet Functions | |||
delete duplicate then combine text | Excel Discussion (Misc queries) | |||
How do you delete duplicate addresses, but keep duplicate names? | Excel Discussion (Misc queries) | |||
delete duplicate names in a column | New Users to Excel |