Free Microsoft Excel 2013 Quick Reference

Change row color for total rows Results

Hello all,

I have a pivot table in which I would like to conditionally format the Total rows. I can use the Fill Color tool to give all Total Rows for a field to a certain color. I double click on the total field and it highlights all Total rows for that field so I just have to do the color fill once and it works for all of them. If the data changes when the chart is refreshed the Total Rows maintain their color even if they move.

Problem is I would like to conditionally format the Total Rows. It works great when I double click the field for that Total Row and do my condition and pick a color. I can pick one row and it will fill in the corresponding Totals for that field down the pivot table. However, if the data changes the conditional formatting does not follow the total row around like it does for the regular Fill Color Totals.

Is it possible to use conditional formatting instead of Fill Color for pivot tables?

I have several table sheets in a workbook with various style colors. For some reason recently one has begun to format new rows the same color as the total row and does not follow the table style.

The first image is the table with the style applied. The second image is what happens when using the Tab key to insert a new row at the end of the table. Note the new row takes on the dark blue color of the total row and not the expected lighter blue shade. I have other tables in this same workbook that do NOT do this. I also have numerous tables in other wookbooks that function just fine.

It's just this one worksheet that insists on making new rows at the end of the table the same color as the total row. Even if I use the Insert --> Table Rows command, the new row is the same dark blue as the total row. If I Insert --> Sheet Row, the new row is formatted in the correct alternating color.

Even if I change the table style to another color, say the turquoise or the red, (3rd example) when using Tab at the end of the table the new row is dark blue like the original table style (4th example).

Any ideas? Not a show stopper but it's a pain to have to apply the Format Painter to all the new cells of a new row or resort to using Insert --> Sheet Row.

Ive attached a spreadsheet that I put together tonight with a macro and some examples. Try not to laugh at my macro. I know its bad and not efficient, but since I am still new to macros and absolutely suck at anything code related, it will take me 50 hours to make it nice. So, Im happy with it just working

I want to use this spreadsheet to track billable hours against each of my projects. This worksheet will allow me to enter time hours for each project and at the end of the week click the button on the first sheet and have all the information compiled into one sheet in order of project with the ID, name, date of work, description of billable time, number of hours, and the total hours for that project this week. The total hours field is a little weird, as its on the first row only of that projects list of entries in the project's worksheet and the first sheet where all projects will be listed. It is the only place I could think to put it that would allow me to see it on each sheet and prevent excess rows from being pasted into the first sheet.

Here is my issue, as I close certain projects and open other projects, I do not want to have to manually edit my macro to account for the deletion of sheets, or the addition of new sheets. I know I could add a message box that would allow me to type in the project name and add a new sheet with that name, but that is where my knowledge stops. I dont know how to also apply the worksheet name to a table name and also apply the changes to a Macro through the message box input.

On the flip side, is there just an easier way to go about this? Basically all I need on that first sheet is the ID, project name, and total hours billed listed once for each project followed by all of the descriptions of billable time and the hours for each description. The only reason I am currently using tables in the sheets is because I can filter out the blank rows so that Im not copying a ton of blank rows each time I copy and paste from one sheet to that first sheet.

As an example, it would be fine if that first sheet looked like this, rather than having column entries duplicated for each row, but its not a big deal either way:

SP ID 1234 Project A Total Hours Billed 15
Date Description of Billable Time Hours Billed
28-Feb-11 Project description entry 1 5
02-Mar-11 Project description entry 2 10

SP ID 5678 Project B Total Hours Billed 25
Date Description of Billable Time Hours Billed
01-Mar-11 Project description entry 1 15
02-Mar-11 Project description entry 2 10

If anyone has any suggestions, Id really appreciate the help.

Thanks.

Current Macro:
Sub CompileWeeklyHours()
'
' CompileWeeklyHours Macro
'

'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets("All Project Billable Hours").Select
    Cells.Select
    Selection.Clear
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "All Recorded Billable Hours "
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "SP ID"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "Project Name"
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "Date of Work"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "Description of Billable Time"
    Range("E3").Select
    ActiveCell.FormulaR1C1 = "Hours Billed"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "Total Hours Billed"
    
    Sheets("SDL - Jonesboro radd002 Split").Select
    ActiveSheet.ListObjects("TableJonesboroRadd002Split").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableJonesboroRadd002Split").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    'Sheets("SDL - Jonesboro radd002 Split").ShowAllData
    
    
    Sheets("SDL - Carthage N2D").Select
    ActiveSheet.ListObjects("TableCarthageN2D").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableCarthageN2D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
        Sheets("SDL - Stuttgart N2D").Select
    ActiveSheet.ListObjects("TableStuttgartN2D").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableStuttgartN2D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste

    Sheets("Insight Part 1").Select
    ActiveSheet.ListObjects("TableInsightPart1").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableInsightPart1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
       Sheets("Admin Time").Select
    ActiveSheet.ListObjects("TableAdminTime").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableAdminTime").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
       Sheets("Documentation and Process").Select
    ActiveSheet.ListObjects("TableDocsProcess").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableDocsProcess").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
        Sheets("All Project Billable Hours").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.ClearFormats
    
    Range("A2:F2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
        Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A3:F3").Select
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    Columns("C:c").Select
    Selection.NumberFormat = "[$-409]d-mmm-yy;@"
    
    'Columns("E:F").Select
    'With Selection.NumberFormat = "0.0"
    'End With

    
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Range("a1:f1").Select
    
    
    Dim ws As Worksheet
    On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
    ws.ShowAllData
    Next ws
    On Error GoTo 0


    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub


I need help please. I am just starting vba and am lost. I have been reading the different color formatting codes/formulas listed in here and I am not sure what I am doing wrong.

I have a spreadsheet that has 7 columns and about 12 rows in each section. There are a total of 5 sections like this on a worksheet. I would like to have the background color of a cell change automatically based on the contents that are typed into the cell. For example if "O FOH", "M FOH" or "C FOH" is typed into a cell, it needs to change blue. If "O RET", M RET" or "C RET" is typed into a cell, it needs to change to light green, etc.. Can someone please help? Thank you for your help.

Need help totaling units by style, color & size on Multiple Purchase Orders

I have master purchase order work sheet, Master, where I have entered what I plan to order for the fall season. I now need to create 4 separate worksheet purchase orders--Sept, Oct, Nov & Dec deliveries based on my total units on the Master PO worksheet (I am on allocation).

My column headings are Style(E), Description (F), Color (G), Size (H), Total units (I), see example. My data starts on row 2.

Style Description Color Size Total Units
1873 W BAILEY BLK 5 2
1873 W BAILEY BLK 6 4
1873 W BAILEY BLK 7 5

For my PO order for Sept, let’s say I order 1/5, 2/6, 2/7, for Oct I order 1/6, for Nov 1/6 & Dec 1/5, 1/6, 3/7. I need a formula that I can use that will subtract the units placed on my Sept, Oct, Nov & Dec purchase order worksheets from the Master PO worksheet so that I know how many units are left to order on the other purchase orders as I enter the units.

Let’s say I create an additional column on the master PO called Balance (J). The formula I am seeking would give me be a balance of 1/5, 2/6, 3/7 left to order after entering the units for Sept.; the balance should be 0 after entering the Dec units. If I change any units on any of the Sept to Dec work orders, the formula would update the balances of units accordingly.

Any help would be deeply appreciated. Thanks.

Hi all,

I've a marco that inserting rows below each subtotal. However, when the rows are inserted, they carry over formatof the previous row which is filled with color. How can I change that?

Here's my code:


	VB:
	
 
Dim rRw As Range 
Sheets("Sales").Activate 
Set rRw = Range("D1") 
For i = 1 To WorksheetFunction.CountIf(Columns(4), "* Total") 
    Set rRw = Columns(4).Find(What:="* Total", After:=rRw, LookIn:=xlFormulas, _ 
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
    MatchCase:=False) 
     
    If rRw.Value  "Grand Total" Then 
        rRw.Offset(1, 0).EntireRow.Insert 
    End If 
Next i 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Appreciate if anyone can help. Thanks.

Hi

I am a new user to this board and I must say I am really thankful to what all help I've been able to receive from this website in order to learn and understand how Excel Macro's work.

I am trying to create a Macro, which can actually retrieve data from Hyperion Essbase system for my retrieve template (already completed this Macro).

Second Part:

Now I am working on creating this Macro to create an email using Outlook which will have the message as below:

-------------------------------------------------------------------------
Hi,

Please find the link to Jul-10 file for 06-08-10 for Group 1 :

link to the file:

"D:Documents and SettingsadminDesktopNew.xlsx"

Total = $ Debit 409k

1. Random 1 = $ Credit 50k (Need to check with Dept)
2. Random 4 = $ Credit 60k (Genuine)a. Random 2 = $ Credit 50k (Cause Known)b. Random 3 = $ Credit 10k (Unsure)3. Random 5 = $ Nil
4. Random 6 = $ Credit 100k (Expected)
5. Random 7 = $ Credit 1k (Immaterial)
6. Random 8 = $ Debit 10k (Investigation pending)
7. Random 9 = $ Debit 30k (Investigation pending)
8. Random 10 = $ Debit 550k (Investigation pending)
9. Random 11 = $ Debit 30k (Investigation pending)

Thanks and Kind regards,

Signature [Auto signature should come up]

-------------------------------------------------------------------------

The format is really critical, it has to have the format as stated above only and no change.

The numbers for each item gets populated from Column 'H' in the attached excel file, the Debits needs to appear in Red (Bold) and Credits in Green, the comment section in the attached file (Column BX) comes after each line in brackets in Black (Bold color only) as shown on the above format.

I am struggling with the formatting section when trying to code, any help would be useful.

Thanks and Kind regards

Rahul


	VB:
	
 ShellExecute Lib "shell32.dll" _ 
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ 
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _ 
ByVal nShowCmd As Long) As Long 
 
Sub SendEMail() 
    Dim Email As String, Subj As String 
    Dim Msg As String, URL As String 
    Dim Today As Date 
    Today = Date 
    Dim r As Integer, x As Double 
    For r = 2 To 4 'data in rows 2-4
         '       Get the email address
        Email = Cells(r, 2) 
         
         '       Message subject
        Subj = Cells(r, 3) 
         
         '       Compose the message
        Msg = "" 
        Msg = Msg & "Please find the link to " & Cells(r, 4) & Format(Today, "DD-MMM-YY") & " " & vbCrLf 
         'ActiveWorkbook.SaveAs Filename:="My_File" & Format(Today, "YYYY_MM_DD")
         'Msg = Msg & "FOF variance" & Cells(r, 4) - EEM -    Audience = $  Credit 25kMsg & Cells(r, 3).Text & "." &   vbCrLf
&  vbCrLf
         
         
         
         '       Replace spaces with %20 (hex)
        Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20") 
        Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20") 
         
         '       Replace carriage returns with %0D%0A (hex)
        Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A") 
         
         '       Create the URL
        URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg 
         
         '       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus 
         
         '       Wait two seconds before sending keystrokes
         'Application.Wait (Now + TimeValue("0:00:02"))
         'Application.SendKeys "%s"
    Next r 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello all, I have a Q for you guys.

Within the code I am asking excel to sort two difference worksheets with virtually the same code, except that one of the worksheets does not get sorted. If I step through the code, it works and the worksheet is sorted, but if I just run the macro the worksheet does not get sorted, as if the line of code in question is being skipped.

Pointedly, my question is - Why does the code work while debugging (stepping through) but not when I generally run it?

Also, as far as the code is concerned, I am sure that the all variables contain the information I need them to and am also sure that any ranges created from those variables are also the ranges they should be.

Here are the two lines of code that are supposed to sort. The UBOC cash sheet gets sorted, but the LNB cash sheet does not.

Thanks All
Bryce


	VB:
	
wsUBOC.Range("A5:G" & lUBOCRow).Sort Key1:=Range("A6"), Order1:=xlAscending, Key2:=Range("D6"), _ 
Order2:=xlAscending, Key3:=Range("G6"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, _ 
MatchCase:=False, Orientation:=xlTopToBottom 
 
 'Sort the LNB cash sheet
wsLNB.Range("A1:G" & lLNBRow).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("C2"), _ 
Order2:=xlAscending, Key3:=Range("G2"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, _ 
MatchCase:=False, Orientation:=xlTopToBottom 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
here is all of the code for context


	VB:
	
 Balance() 
    Dim wsUBOC As Worksheet, wsLNB As Worksheet, wsSummary As Worksheet, wSheet As Worksheet, wsException As Worksheet 
    Dim wSheet2 As Worksheet, wsWire As Worksheet, WS As Worksheet, wsDuplicate As Worksheet 
    Dim lUBOCRow As Long, lUBOCNewRow As Long, lLNBRow As Long, lSummaryRow As Long, w1Row As Long 
    Dim w2Row As Long, w3Row As Long, w4row As Long, wReconRow As Long, lReconLastRow As Long 
    Dim lExceptionRow As Long, lExceptionRow1 As Long, DuplicateRows As Long 
    Dim cBuy As Currency, cSell As Currency, cLNBBuy As Currency, cLNBSell As Currency 
    Dim x As Integer, Y As Integer, Var As Integer, ColUboc As Integer, ColLnb As Integer, Z As Integer, UBOCDuplicate As
Integer 
    Dim LNBDuplicate As Integer, A As Integer 
    Dim FindAcct As Variant, FindLNBAcct As Variant, FindUBOCAcct As Variant 
    Dim NotF As Boolean, NotFLnb As Boolean 
    Dim rngFound As Range 
     
     
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
     
    For Each WS In Worksheets 
        On Error Resume Next 
        If WS.Name = "SUMMARY INFO" Or WS.Name = "EXCEPTIONS" Or WS.Name = "Duplicate Trades" Then 
            WS.Delete 
        End If 
    Next WS 
     
    Set wsUBOC = Worksheets("UBOC") 
    Set wsLNB = Worksheets("LNB") 
    Set wsWire = Worksheets("Wire") 
     
     
    lUBOCRow = wsUBOC.Range("A" & Rows.Count).End(xlUp).Row 
    lLNBRow = wsLNB.Range("A" & Rows.Count).End(xlUp).Row 
     
     'Sort the UBOC cash sheet.
    wsUBOC.Range("A5:G" & lUBOCRow).Sort Key1:=Range("A6"), Order1:=xlAscending, Key2:=Range("D6"), _ 
    Order2:=xlAscending, Key3:=Range("G6"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, _ 
    MatchCase:=False, Orientation:=xlTopToBottom 
     
     'Sort the LNB cash sheet
    wsLNB.Range("A1:G" & lLNBRow).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("C2"), _ 
    Order2:=xlAscending, Key3:=Range("G2"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, _ 
    MatchCase:=False, Orientation:=xlTopToBottom 
     
     
     '**************************************************************************************************************'
     'Test both cash sheets for duplicate entries. If entries exist, then place them on the worksheet and highlight '
     'the second entry on the respective cash sheet. If there are no duplicates, then this worksheet is delted from '
     'the workbook before the code is finished running.                                                             '
     '**************************************************************************************************************'
     
    lUBOCNewRow = wsUBOC.Range("A" & Rows.Count).End(xlUp).Row 
    Set wsDuplicate = Worksheets.Add 
    wsDuplicate.Name = "Duplicate Trades" 
     
    For UBOCDuplicate = 6 To lUBOCNewRow 
        If wsUBOC.Range("G" & UBOCDuplicate).Value = wsUBOC.Range("G" & UBOCDuplicate + 1).Value And wsUBOC.Range("D" &
UBOCDuplicate).Value = wsUBOC.Range("D" & UBOCDuplicate + 1).Value Then 
            With wsDuplicate.Range("A1") 
                .Value = "UBOC Duplicate Trades" 
                .Range("A1:G1").HorizontalAlignment = xlCenterAcrossSelection 
                .Font.Size = 12 
                .Font.Bold = True 
            End With 
            wsUBOC.Range("A" & UBOCDuplicate + 1, "G" & UBOCDuplicate + 1).Interior.ColorIndex = 46 
            wsUBOC.Rows(5).Copy wsDuplicate.Range("A3") 
            wsUBOC.Rows(UBOCDuplicate + 1).Copy wsDuplicate.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 
        End If 
    Next UBOCDuplicate 
     
    DuplicateRows = wsDuplicate.Range("A65536").End(xlUp).Row 
     
    For LNBDuplicate = 2 To lLNBRow 
        If wsLNB.Range("D" & LNBDuplicate).Value  "" Then 
            If wsLNB.Range("D" & LNBDuplicate).Value = wsLNB.Range("D" & LNBDuplicate + 1).Value And wsLNB.Range("C" &
LNBDuplicate).Value = wsLNB.Range("C" & LNBDuplicate + 1).Value Then 
                With wsDuplicate.Range("A" & DuplicateRows).Offset(5, 0) 
                    .Value = "LNB Duplicate Trades" 
                    .Range("A" & DuplicateRows, "G" & DuplicateRows).HorizontalAlignment = xlCenterAcrossSelection 
                    .Font.Size = 12 
                    .Font.Bold = True 
                End With 
                wsLNB.Range("A" & LNBDuplicate + 1, "G" & LNBDuplicate + 1).Interior.ColorIndex = 46 
                wsLNB.Rows(1).Copy wsDuplicate.Range("A" & DuplicateRows).Offset(6, 0) 
                wsLNB.Rows(LNBDuplicate + 1).Copy wsDuplicate.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 
            End If 
        Else 
            If wsLNB.Range("E" & LNBDuplicate).Value  "" Then 
                If wsLNB.Range("E" & LNBDuplicate).Value = wsLNB.Range("E" & LNBDuplicate + 1).Value And wsLNB.Range("C" &
LNBDuplicate).Value = wsLNB.Range("C" & LNBDuplicate + 1).Value Then 
                    With wsDuplicate.Range("A" & DuplicateRows).Offset(5, 0) 
                        .Value = "LNB Duplicate Trades" 
                        .Range("A" & DuplicateRows, "G" & DuplicateRows).HorizontalAlignment = xlCenterAcrossSelection 
                        .Font.Size = 12 
                        .Font.Bold = True 
                    End With 
                    wsLNB.Range("A" & LNBDuplicate + 1, "G" & LNBDuplicate + 1).Interior.ColorIndex = 46 
                    wsLNB.Rows(1).Copy wsDuplicate.Range("A" & DuplicateRows).Offset(6, 0) 
                    wsLNB.Rows(LNBDuplicate + 1).Copy wsDuplicate.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 
                End If 
            End If 
        End If 
    Next LNBDuplicate 
     
    If wsDuplicate.Range("A65536").End(xlUp).Row  lSummaryRow Then Exit For 
    Next x 
     
    Let cLNBBuy = 0 
    Let cLNBSell = 0 
    Let A = 4 
    For Y = 2 To lLNBRow 
        If wsLNB.Range("A" & Y).Value  wsSummary.Range("A" & A).Value Then 
Goto BeginHere: 
        End If 
        While wsLNB.Range("A" & Y).Value = wsSummary.Range("A" & A).Value 
            If wsLNB.Range("D" & Y).Value < 0 Then 
                cLNBBuy = cLNBBuy + wsLNB.Range("D" & Y).Value 
            Else 
                cLNBSell = cLNBSell + wsLNB.Range("E" & Y).Value 
            End If 
            Y = Y + 1 
        Wend 
        FindLNBAcct = wsSummary.Range("A4:A" & lSummaryRow).Find(What:=wsSummary.Range("A" & A).Value, LookIn:=xlValues,
LookAt:=xlWhole).Row 
        wsSummary.Range("D" & FindLNBAcct).Value = cLNBBuy 
        wsSummary.Range("E" & FindLNBAcct).Value = cLNBSell 
        cLNBBuy = 0 
        cLNBSell = 0 
BeginHere: 
        Y = Y - 1 
        A = A + 1 
        If A > lSummaryRow Then Exit For 
    Next Y 
     
     
     '*********************************************************************************************************'
     'Move down columns F and G on the summary worksheet adding the variances, if any, to each account        '
     '*********************************************************************************************************'
     
    For Var = 4 To lSummaryRow 
        wsSummary.Range("F" & Var).Value = wsSummary.Range("B" & Var).Value - wsSummary.Range("D" & Var).Value 
        wsSummary.Range("G" & Var).Value = wsSummary.Range("C" & Var).Value - wsSummary.Range("E" & Var).Value 
    Next Var 
     
     '*********************************************************************************************************'
     'The following With statements are formating the newly added information on the summary worksheet         '
     '*********************************************************************************************************'
     
    With wsSummary.Range("A65356").End(xlUp).Offset(2, 0) 
        .Value = "Totals" 
        .Font.Bold = True 
        .Font.Size = 14 
    End With 
     
    With wsSummary.Range("A65356").End(xlUp).Offset(6, 0) 
        .Value = "Prepared By:" 
        .Font.Bold = True 
        .Font.Size = 11 
        .HorizontalAlignment = xlRight 
    End With 
     
    With wsSummary.Range("A65356").End(xlUp).Offset(2, 0) 
        .Value = "Approved By:" 
        .Font.Bold = True 
        .Font.Size = 11 
        .HorizontalAlignment = xlRight 
    End With 
     
    With wsSummary.Range("A65356").End(xlUp).Offset(2, 0) 
        .Value = "Approved By:" 
        .Font.Bold = True 
        .Font.Size = 11 
        .HorizontalAlignment = xlRight 
    End With 
     
    wsSummary.Range("A65356").End(xlUp).Offset(-4, 1).Borders(xlEdgeBottom).Weight = xlMedium 
    wsSummary.Range("A65356").End(xlUp).Offset(-2, 1).Borders(xlEdgeBottom).Weight = xlMedium 
    wsSummary.Range("A65356").End(xlUp).Offset(0, 1).Borders(xlEdgeBottom).Weight = xlMedium 
     
    With wsSummary.Range("B" & lSummaryRow).Offset(2, 0) 
        .Formula = Application.WorksheetFunction.Sum(wsSummary.Range("B3:B" & lSummaryRow)) 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 11 
        .Font.Bold = True 
    End With 
     
    With wsSummary.Range("C" & lSummaryRow).Offset(2, 0) 
        .Formula = Application.WorksheetFunction.Sum(wsSummary.Range("C3:C" & lSummaryRow)) 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 11 
        .Font.Bold = True 
    End With 
     
    With wsSummary.Range("D" & lSummaryRow).Offset(2, 0) 
        .Formula = Application.WorksheetFunction.Sum(wsSummary.Range("D3:D" & lSummaryRow)) 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 11 
        .Font.Bold = True 
    End With 
     
    With wsSummary.Range("E" & lSummaryRow).Offset(2, 0) 
        .Formula = Application.WorksheetFunction.Sum(wsSummary.Range("E3:E" & lSummaryRow)) 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 11 
        .Font.Bold = True 
    End With 
     
    With wsSummary.Range("F" & lSummaryRow).Offset(2, 0) 
        .Formula = Application.WorksheetFunction.Sum(wsSummary.Range("F3:F" & lSummaryRow)) 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 11 
        .Font.Bold = True 
    End With 
     
    With wsSummary.Range("G" & lSummaryRow).Offset(2, 0) 
        .Formula = Application.WorksheetFunction.Sum(wsSummary.Range("G3:G" & lSummaryRow)) 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 11 
        .Font.Bold = True 
    End With 
     
     
     '************************************************************************************************************'
     'Determin if a wire is incoming or outgoing. This value is based on UBOC's information and an outgoing wire  '
     'results if UBOC's Buys are LESS than UBOC Sells aka the resulting number is positive.                       '
     '************************************************************************************************************'
     
    If wsSummary.Range("B" & lSummaryRow).Offset(2, 0).Value + wsSummary.Range("C" & lSummaryRow).Offset(2, 0).Value < 0 Then

        wsSummary.Range("A" & lSummaryRow).Offset(4, 0).Value = "Incoming Wire" 
        wsSummary.Range("B" & lSummaryRow).Offset(4, 0).Value = wsSummary.Range("B" & lSummaryRow).Offset(2, 0).Value +
wsSummary.Range("C" & lSummaryRow).Offset(2, 0).Value 
        wsSummary.Range("B" & lSummaryRow, "C" & lSummaryRow).Offset(4, 0).HorizontalAlignment = xlCenterAcrossSelection 
        wsWire.Range("C9", "V9").Value = "" 'if the wire is incling leave the wire sheet blank
    Else 
        wsSummary.Range("A" & lSummaryRow).Offset(4, 0).Value = "Outgoing Wire" 
        wsSummary.Range("A" & lSummaryRow).Offset(5, 0).Value = "Clearing Account" 
        wsSummary.Range("A" & lSummaryRow).Offset(5, 1).Value = "#19950019" 
        With wsSummary.Range("A" & lSummaryRow, "B" & lSummaryRow).Offset(5, 0) 
            .Font.Size = 16 
            .Font.Bold = True 
        End With 
        wsSummary.Range("B" & lSummaryRow).Offset(4, 0).Value = wsSummary.Range("B" & lSummaryRow).Offset(2, 0).Value +
wsSummary.Range("C" & lSummaryRow).Offset(2, 0).Value 
        wsSummary.Range("B" & lSummaryRow, "C" & lSummaryRow).Offset(4, 0).HorizontalAlignment = xlCenterAcrossSelection 
        wsWire.Range("C9").Value = wsSummary.Range("B" & lSummaryRow).Offset(4, 0).Value 
        wsWire.Range("V9").Value = wsSummary.Range("B" & lSummaryRow).Offset(4, 0).Value 
    End If 
     
    With wsWire.Range("C9", "V9") 
        .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
        .Font.Size = 10 
    End With 
     
    With wsSummary.Range("A" & lSummaryRow, "B" & lSummaryRow).Offset(4, 0) 
        .Font.Size = 16 
        .Font.Bold = True 
    End With 
     
    wsSummary.Range("A" & lSummaryRow, "G" & lSummaryRow).Offset(2, 0).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium

    wsSummary.Range("B" & lSummaryRow, "C" & lSummaryRow).Offset(2, 0).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium

    wsSummary.Range("D" & lSummaryRow, "E" & lSummaryRow).Offset(2, 0).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium

    wsSummary.Columns("A:G").AutoFit 
    Application.DisplayAlerts = True 
     
     
     '*********************************************************************************************************'
     'The exception sheet is created below                                                                     '
     '*********************************************************************************************************'
    Set wsException = Sheets.Add 
    wsException.Name = "EXCEPTIONS" 
     
     
     '*********************************************************************************************************'
     'Concatenate the account, cusip and amount on each cash sheet. The result is used to determin what is     '
     'missing from each cash sheet.                                                                            '
     '*********************************************************************************************************'
     
    wsUBOC.Range("h6").Value = "=a6&d6&g6" 
    wsUBOC.Range("h6").Copy wsUBOC.Range("h7:h" & lUBOCNewRow) 
    wsUBOC.Range("h6:h" & lUBOCNewRow).Copy 
    wsUBOC.Range("h6:h" & lUBOCNewRow).pastespecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
     
    wsLNB.Range("h2").Value = "=a2&c2&d2&e2" 
    wsLNB.Range("h2").Copy wsLNB.Range("h3:h" & lLNBRow) 
    wsLNB.Range("h2:h" & lLNBRow).Copy 
    wsLNB.Range("h2:h" & lLNBRow).pastespecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
     
    wReconRow = 3 'begin on row 3 of the exception sheet
     
    With wsException.Range("A1") 
        .Value = "UBOC Exceptions" 
        .Range("A1:G1").HorizontalAlignment = xlCenterAcrossSelection 
        .Font.Size = 14 
        .Font.Bold = True 
    End With 
     
    wsUBOC.Rows(5).Copy wsException.Range("A2") 
     
     
    For w1Row = 6 To lUBOCNewRow 
        On Error Goto NotFound 
        NotF = False 
        w2Row = wsLNB.Range("H:H").Find(What:=wsUBOC.Cells(w1Row, 8).Value, LookIn:=xlValues, LookAt:=xlWhole).Row 
        If NotF = False Then 
        End If 
    Next w1Row 
    Let wReconRow = 0 
     
    wReconRow = wsException.Range("A65536").End(xlUp).Row + 6 
     
    With wsException.Range("A" & wReconRow) 
        .Value = "LNB Exceptions" 
        .Font.Size = 14 
        .Font.Bold = True 
    End With 
     
    wsException.Range("A" & wReconRow & ":" & "G" & wReconRow).HorizontalAlignment = xlCenterAcrossSelection 
     
    wsLNB.Rows(1).Copy Destination:=wsException.Range("A" & wReconRow).Offset(1, 0) 
    Let wReconRow = 0 
    wReconRow = wsException.Range("A65536").End(xlUp).Offset(1, 0).Row 
     
     
    For w3Row = 2 To lLNBRow 
        On Error Goto NotFoundLnb 
        NotFLnb = False 
        w4row = wsUBOC.Range("H:H").Find(What:=wsLNB.Cells(w3Row, 8).Value, LookIn:=xlValues, LookAt:=xlPart,
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row 
        If NotF = False Then 
        End If 
    Next w3Row 
     
    wsLNB.Range("h2:h" & lLNBRow).ClearContents 
    wsUBOC.Range("h6:h" & lUBOCNewRow).ClearContents 
    wsException.Columns("A:H").AutoFit 
     
     'Format any exceptions on the exception sheet
    lExceptionRow = wsException.Range("A3:A" & Rows.Count).End(xlDown).Row 
    lExceptionRow1 = wsException.Range("A" & Rows.Count).End(xlUp).Row 
     
    wsException.Range("G3:G" & lExceptionRow).Style = "Comma" 
    wsException.Range("E3:E" & lExceptionRow).Style = "Comma" 
    wsException.Range("F3:F" & lExceptionRow).NumberFormat = "d-mmm" 
    wsException.Range("B" & lExceptionRow + 1, "B" & lExceptionRow1).NumberFormat = "d-mmm" 
    wsException.Range("D" & lExceptionRow + 1, "E" & lExceptionRow1).Style = "Comma" 
    wsException.Range("G" & lExceptionRow + 1, "G" & lExceptionRow1).Style = "Comma" 
     
    Exit Sub 
     
NotFound: 
    NotF = True 
    For ColUboc = 1 To 7 
        wsException.Cells(wReconRow, ColUboc) = wsUBOC.Cells(w1Row, ColUboc) 
    Next ColUboc 
    wsException.Cells(wReconRow, 8) = "Not Found in LNB cash sheet" 
    wReconRow = wReconRow + 1 
    Resume Next 
     
NotFoundLnb: 
    NotFLnb = True 
    For ColLnb = 1 To 7 
        wsException.Cells(wReconRow, ColLnb) = wsLNB.Cells(w3Row, ColLnb) 
    Next ColLnb 
    wsException.Cells(wReconRow, 8) = "Not Found in UBOC cash sheet" 
    wReconRow = wReconRow + 1 
    Resume Next 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi,
Good Morning! i am stuck up in a problem..... i have entered data in one sheet nearly 1500 rows. i have segregated the rows by giving different color in cells/ fonts.Total no. of colors i have used is 5(say) which has got 5 different interpretation. Now... i want a program which can help me to call all 5 colors in 5 different sheets so that any time i enter/change color in the master sheet all 5 sheets get updated. This will help me to prepare MIS for the management.

Regards,

Rahul Singh

I am by no means an excel guru, and this is so far over my head that its almost comical, but it still needs to be done.

I have a picture of the chart I created here: http://img.photobucket.com/albums/v1...2785/chart.jpg, and just to give a little explaination on it: The horizontal yellow bars are representative of an entire task, with a specific start and end date.
The diamonds are represenative of specific milestones during that task.
Anything gray with red bars or any color formatting was just to deter people from touching it when they updated the data.

What I've been asked to do is to streamline the process that they need represented by this chart. Along with the milestones I also need something like a description tag. I need this all to be added using ONLY the spreadsheet, without touching the chart at all. In other words, the chart has a milestone for 5/15 for Company C. Next to this, I need a description tag - The catch is, the data can ONLY be added in the spreadsheet, so the description needs to be typed there and added onto the chart in the correct place next to the correct milestone, regardless of if the milestones move or the dates change, and the chart is totally auto updated. I thought this could be done by assigning a text box to each milestone, however I beleive I would lose the placement functonality - so if there is a way to do this please let me know.

Each milestone is also representative of a different thing. A red milestone could be something like a specific thing would be completed, whereas a green milestone means its 1/2way completed. I also need this functionality to be added through the spreadsheet. So, another column stating that Milestone 2 in row 2 is red, and have it auto update on the chart. Each milestone could possibly be a different color, so therefore each different milestone needs this functionality. For example. For Company C, Milestone 6/1 needs to be red, and milestone 6/20 needs to be blue, for whatever reason. I need this to be updated through the spreadsheet as well, and reflected in the chart.

The entire project is all about adding things to the spreadsheet, and the chart auto updating without needing to touch it at all.

I have ZERO idea how to do this or even where to begin looking. Does anyone have any ideas at all? If so please help!

I'm not sure if this was clear enough to describe what I needed, so if you need clarification on exactly what I have a question on, please ask!

TYIA!

Good afternoon,

I have been working on an easy spreadsheet the last few days. At least, it's very easy compared to the one I've been coming to y'all with lately. I am only now beginning to realize just how powerful Excel can be and have started something for myself.

I am the only one in the office that works claims for our clients. I've started a spreadsheet showing last name, first name, company, start date, end date, total time, and one cell off to the side showing me an average of time for the entire sheet. There are about 100 entries on this sheet so far.

I just went through them, looking for a few files in particular. I didn't like how it was difficult(ish) to glance at a name and know if I've closed it or not. I can't seem to wrap my mind over how to do this.

When a record gets a date put into the end date column I'd like the row to turn blue for me, so I would know at a glance that it's complete. That sounds like conditional formatting to me, but I just can't figure it out. Can anyone help me? I'm sorry I'm so dang wordy!!

OK I am new here and have found some GREAT answers! but I think I really need to post what I am trying to accomplish.

The spreadsheet I am doing has 12 numbers (for each month in the year) in cells x and y, those numbers will then tell me when I should pay what is in p&q for cell x and t&u for cell y. I have then set up an Array that adds the amounts (monthly) separately based upon cells x and y. My boss wants color added to these totals (both individually and summarized) the Summarized cells can be set once and be done but the individual cells can change when items get deleted and added.

Here is what I have written/taken from other posts and it works great for column x! What I am trying to do now is add another range to using the same color scheme.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, d As Range, fc As Long, bc As Long, bf As Boolean
Set d = Intersect(Range("x:x"), Target)
If d Is Nothing Then Exit Sub
For Each c In d
Select Case UCase(c)
Case 4
fc = 2: fb = True: bc = 3
Case 5
fc = 2: fb = True: bc = 5
Case 6
fc = 2: fb = True: bc = 1
Case 7
fc = 2: fb = True: bc = 10
Case 8
fc = 2: fb = True: bc = 45
Case 9
fc = 3: fb = True: bc = 1
Case Else
fc = 1: fb = False: bc = xlNone
End Select
With Cells(c.Row, 16).Resize(, 2)
.Font.ColorIndex = fc
.Font.Bold = fb
.Interior.ColorIndex = bc
End With

The other range is going to look in column y instead of x and it will change the colors in the columns t & u that relate to the specific row. What I thought I needed was to just copy and paste the following changing the references but it doesn't like it. (I HOPE this explains it properly)

For Each c In d
Select Case UCase(c)
Case 4
fc = 2: fb = True: bc = 3
Case 5
fc = 2: fb = True: bc = 5
Case 6
fc = 2: fb = True: bc = 1
Case 7
fc = 2: fb = True: bc = 10
Case 8
fc = 2: fb = True: bc = 45
Case 9
fc = 3: fb = True: bc = 1
Case Else
fc = 1: fb = False: bc = xlNone
End Select
With Cells(c.Row, 20).Resize(, 2)
.Font.ColorIndex = fc
.Font.Bold = fb
.Interior.ColorIndex = bc
End With

I even tried to add ranges c1, d1.

I hope I have learned enough to explain exactly what I am trying to accomplish and any help would be appreciated!

XP Pro - Excel 2003 SP2

I maintain a monthly job task list and I prioritize jobs by how soon they need to be done.
Right now, I have a conditional format setup comparing the due date of the task to the current date. Depending on the amt of days, the row of cells containing all the information for that job has a different fill color. This is my current CF setup for Row 4 in this case:

Condition 1 =IF((B4-3)>=TODAY(),TRUE,FALSE) Format --- Fill Color "Light Yellow"
Condition 2 =IF((B4-2)>=TODAY(),TRUE,FALSE) Format --- Fill Color "Yellow"
Condition 3 =IF((B4-0)>=TODAY(),TRUE,FALSE) Format --- Fill Color "Gold"

My problem I just now noticed that on Fridays anything due on Monday is going to show as 3 days away and be a lower priority. So basically I need to compare Weekdays or Workdays instead of total days. I've attempted to use NETWORKDAYS but to no avail.

As a side issue: When I try to copy the format from left to right across the row, the cell I reference changes (as expected) and I have to manually change each one. Is there a way to make it carry over to any cell in the row I decided to Fill???

My apologies If my description wasn't clear enough.

Shown below is an advanced macro that clears up another spreadsheet. The only problem is that I did not write this macro but I am trying to figure out how to edit it. This macro cleans up another excel spreadsheet and then deletes duplicates and subtotals information. I'm trying to figure out how to edit this macro to delete additional duplicates, because it is not getting all of them in each excel spreadsheet.

The excel spreadsheet that is being edited, looks a little like this before the macro is ran:

Code:
				No Column
Dealer Number	Primary Dba Name	Caller Full Name	Channel Name	NONE
0570      	Fritz's Harley-Davidson	    	Fax	1 
0570      	Fritz's Harley-Davidson	    	Subtotal	1 
0570      	Fritz's Harley-Davidson	Andy (Panda) Cunningham	Telephone	7 
0570      	Fritz's Harley-Davidson	Andy (Panda) Cunningham	Subtotal	7 
0570      	Fritz's Harley-Davidson	Dan ((vehicle #1)) Height	Telephone	2 
0570      	Fritz's Harley-Davidson	Dan ((vehicle #1)) Height	Subtotal	2 
0570      	Fritz's Harley-Davidson	Ed Grivelrod	Telephone	1 
0570      	Fritz's Harley-Davidson	Ed Grivelrod	Subtotal	1 
0570      	Fritz's Harley-Davidson	Fax 2	Fax	1 
0570      	Fritz's Harley-Davidson	Fax 2	Subtotal	1 
0570      	Fritz's Harley-Davidson	George (Drego) Albano	Telephone	19 
0570      	Fritz's Harley-Davidson	George (Drego) Albano	Subtotal	19 
0570      	Fritz's Harley-Davidson	Jamie Mcgarty	Telephone	1 
0570      	Fritz's Harley-Davidson	Jamie Mcgarty	Subtotal	1 
0570      	Fritz's Harley-Davidson	John P (Woodchuck) Narciso	Telephone	2 
0570      	Fritz's Harley-Davidson	John P (Woodchuck) Narciso	Subtotal	2 
0570      	Fritz's Harley-Davidson	Laurie (Foof) Ferriero	Telephone	1 
0570      	Fritz's Harley-Davidson	Laurie (Foof) Ferriero	Subtotal	1 
0570      	Fritz's Harley-Davidson	Main Email/Fax	Fax	3 
0570      	Fritz's Harley-Davidson	Main Email/Fax	Subtotal	3 
0570      	Fritz's Harley-Davidson	Malone Ranalli	Telephone	1 
0570      	Fritz's Harley-Davidson	Malone Ranalli	Subtotal	1 
0570      	Fritz's Harley-Davidson	Subtotal		39 
0570      	Subtotal			39 
1455      	Harley-Davidson of New York	    	Fax	5 
1455      	Harley-Davidson of New York	    	Subtotal	5 
1455      	Harley-Davidson of New York	Adam Alberghine	Telephone	30 
1455      	Harley-Davidson of New York	Adam Alberghine	Subtotal	30 
1455      	Harley-Davidson of New York	Danielle Melrose	Telephone	3 
1455      	Harley-Davidson of New York	Danielle Melrose	Subtotal	3 
1455      	Harley-Davidson of New York	David  Martin	Telephone	1 
1455      	Harley-Davidson of New York	David  Martin	Subtotal	1 
1455      	Harley-Davidson of New York	Frank Caramico	Telephone	1 
1455      	Harley-Davidson of New York	Frank Caramico	Subtotal	1 
1455      	Harley-Davidson of New York	James  (Jimmy) Holland	Telephone	2 
1455      	Harley-Davidson of New York	James  (Jimmy) Holland	Subtotal	2 
1455      	Harley-Davidson of New York	Subtotal		42 
1455      	Subtotal			42 
1797	Harley-Davidson of Nassau County	    	Fax	11 
1797	Harley-Davidson of Nassau County	    	Subtotal	11 
1797	Harley-Davidson of Nassau County	Bobby C	Telephone	3 
1797	Harley-Davidson of Nassau County	Bobby C	Subtotal	3 
1797	Harley-Davidson of Nassau County	Byron Reich	Telephone	8 
1797	Harley-Davidson of Nassau County	Byron Reich	Subtotal	8 
1797	Harley-Davidson of Nassau County	Dave Kohn	Telephone	2 
1797	Harley-Davidson of Nassau County	Dave Kohn	Subtotal	2 
1797	Harley-Davidson of Nassau County	Elizabeth Bergamini	Telephone	1 
1797	Harley-Davidson of Nassau County	Elizabeth Bergamini	Subtotal	1 
1797	Harley-Davidson of Nassau County	Lisa Valente	Telephone	9 
1797	Harley-Davidson of Nassau County	Lisa Valente	Subtotal	9 
1797	Harley-Davidson of Nassau County	Main Email/Fax	Fax	2 
1797	Harley-Davidson of Nassau County	Main Email/Fax	Subtotal	2 
1797	Harley-Davidson of Nassau County	Michael Nicoletti	Telephone	3 
1797	Harley-Davidson of Nassau County	Michael Nicoletti	Subtotal	3 
1797	Harley-Davidson of Nassau County	Mike Brodsky	Telephone	2 
1797	Harley-Davidson of Nassau County	Mike Brodsky	Subtotal	2 
1797	Harley-Davidson of Nassau County	Nick Palesty	Telephone	3 
1797	Harley-Davidson of Nassau County	Nick Palesty	Subtotal	3 
1797	Harley-Davidson of Nassau County	Phil Melfi	Telephone	15 
1797	Harley-Davidson of Nassau County	Phil Melfi	Subtotal	15 
1797	Harley-Davidson of Nassau County	Tim Magnuson	Telephone	1 
1797	Harley-Davidson of Nassau County	Tim Magnuson	Subtotal	1 
1797	Harley-Davidson of Nassau County	Subtotal		60 
1797	Subtotal			60 
1972	NewRoc Harley-Davidson	    	Fax	7 
1972	NewRoc Harley-Davidson	    	Subtotal	7 
1972	NewRoc Harley-Davidson	Crissy Scopoletti	Telephone	5 
1972	NewRoc Harley-Davidson	Crissy Scopoletti	Subtotal	5 
1972	NewRoc Harley-Davidson	Dave  Delio	Telephone	11 
1972	NewRoc Harley-Davidson	Dave  Delio	Subtotal	11 
1972	NewRoc Harley-Davidson	Dee Klein	Telephone	1 
1972	NewRoc Harley-Davidson	Dee Klein	Subtotal	1 
1972	NewRoc Harley-Davidson	Email/Fax Main	Fax	3 
1972	NewRoc Harley-Davidson	Email/Fax Main	Subtotal	3 
1972	NewRoc Harley-Davidson	Heather Webb	Telephone	1 
1972	NewRoc Harley-Davidson	Heather Webb	Subtotal	1 
1972	NewRoc Harley-Davidson	Jack (917-620-0555) Meskunanus	Telephone	1 
1972	NewRoc Harley-Davidson	Jack (917-620-0555) Meskunanus	Subtotal	1 
1972	NewRoc Harley-Davidson	Jim Maguire	Telephone	2 
1972	NewRoc Harley-Davidson	Jim Maguire	Subtotal	2 
1972	NewRoc Harley-Davidson	John Maguire	Telephone	1 
1972	NewRoc Harley-Davidson	John Maguire	Subtotal	1 
1972	NewRoc Harley-Davidson	John Pluchino	Telephone	8 
1972	NewRoc Harley-Davidson	John Pluchino	Subtotal	8 
1972	NewRoc Harley-Davidson	Minos Tzouflas	Telephone	1 
1972	NewRoc Harley-Davidson	Minos Tzouflas	Subtotal	1 
1972	NewRoc Harley-Davidson	Rob (rg@nrhd.com) Gambichler	Fax	1 
1972	NewRoc Harley-Davidson	Rob (rg@nrhd.com) Gambichler	Subtotal	1 
1972	NewRoc Harley-Davidson	Wayne (wayne@nrhd.com) Sforza	Telephone	3 
1972	NewRoc Harley-Davidson	Wayne (wayne@nrhd.com) Sforza	Subtotal	3 
1972	NewRoc Harley-Davidson	Subtotal		45 
1972	Subtotal			45 
1998	Miracle Mile Harley-Davidson	    	Fax	1 
1998	Miracle Mile Harley-Davidson	    	Subtotal	1 
1998	Miracle Mile Harley-Davidson	Cheryl Reitano	Telephone	2 
1998	Miracle Mile Harley-Davidson	Cheryl Reitano	Subtotal	2 
1998	Miracle Mile Harley-Davidson	doug  paloscio	Telephone	1 
1998	Miracle Mile Harley-Davidson	doug  paloscio	Subtotal	1 
1998	Miracle Mile Harley-Davidson	Email/Fax Main	Fax	5 
1998	Miracle Mile Harley-Davidson	Email/Fax Main	Subtotal	5 
1998	Miracle Mile Harley-Davidson	Eric Ruther	Telephone	4 
1998	Miracle Mile Harley-Davidson	Eric Ruther	Subtotal	4 
1998	Miracle Mile Harley-Davidson	Len (631-327-8444 cell) Campanelli	Telephone	3 
1998	Miracle Mile Harley-Davidson	Len (631-327-8444 cell) Campanelli	Subtotal	3 
1998	Miracle Mile Harley-Davidson	Luciano (Lou) Jaramillo	Telephone	2 
1998	Miracle Mile Harley-Davidson	Luciano (Lou) Jaramillo	Subtotal	2 
1998	Miracle Mile Harley-Davidson	Phil Lynch	Telephone	1 
1998	Miracle Mile Harley-Davidson	Phil Lynch	Subtotal	1 
1998	Miracle Mile Harley-Davidson	Russ Cox	Telephone	9 
1998	Miracle Mile Harley-Davidson	Russ Cox	Subtotal	9 
1998	Miracle Mile Harley-Davidson	Steve Ruckel	Telephone	2 
1998	Miracle Mile Harley-Davidson	Steve Ruckel	Subtotal	2 
1998	Miracle Mile Harley-Davidson	Subtotal		30 
1998	Subtotal			30 
2006	Essex County Harley-Davidson	Al Molaf	Telephone	5 
2006	Essex County Harley-Davidson	Al Molaf	Subtotal	5 
2006	Essex County Harley-Davidson	Clarence  Francis	Telephone	3 
2006	Essex County Harley-Davidson	Clarence  Francis	Subtotal	3 
2006	Essex County Harley-Davidson	Ed Archambault	Telephone	2 
2006	Essex County Harley-Davidson	Ed Archambault	Subtotal	2 
2006	Essex County Harley-Davidson	Fax 2	Fax	2 
2006	Essex County Harley-Davidson	Fax 2	Subtotal	2 
2006	Essex County Harley-Davidson	Gene Booker	Telephone	7 
2006	Essex County Harley-Davidson	Gene Booker	Subtotal	7 
2006	Essex County Harley-Davidson	Jay Toussaint	Telephone	4 
2006	Essex County Harley-Davidson	Jay Toussaint	Subtotal	4 
2006	Essex County Harley-Davidson	Paul Barthelme	Telephone	1 
2006	Essex County Harley-Davidson	Paul Barthelme	Subtotal	1 
2006	Essex County Harley-Davidson	Robert Rutland	Telephone	1 
2006	Essex County Harley-Davidson	Robert Rutland	Subtotal	1 
2006	Essex County Harley-Davidson	Subtotal		25 
2006	Subtotal			25 
3027      	Kosco Harley-Davidson, Inc.	    	Fax	3 
3027      	Kosco Harley-Davidson, Inc.	    	Subtotal	3 
3027      	Kosco Harley-Davidson, Inc.	Barry Donow	Telephone	3 
3027      	Kosco Harley-Davidson, Inc.	Barry Donow	Subtotal	3 
3027      	Kosco Harley-Davidson, Inc.	Denise Kosco	Telephone	2 
3027      	Kosco Harley-Davidson, Inc.	Denise Kosco	Subtotal	2 
3027      	Kosco Harley-Davidson, Inc.	Eric (parts ext 20) Loeffler	Telephone	1 
3027      	Kosco Harley-Davidson, Inc.	Eric (parts ext 20) Loeffler	Subtotal	1 
3027      	Kosco Harley-Davidson, Inc.	Jason ((x. 5)) Kosco	Telephone	3 
3027      	Kosco Harley-Davidson, Inc.	Jason ((x. 5)) Kosco	Subtotal	3 
3027      	Kosco Harley-Davidson, Inc.	Rich Kosco	Telephone	2 
3027      	Kosco Harley-Davidson, Inc.	Rich Kosco	Subtotal	2 
3027      	Kosco Harley-Davidson, Inc.	Subtotal		14 
3027      	Subtotal			14 
3031      	Liberty Harley-Davidson	    	Fax	20 
3031      	Liberty Harley-Davidson	    	Subtotal	20 
3031      	Liberty Harley-Davidson	Anthony Caligiuri	Telephone	1 
3031      	Liberty Harley-Davidson	Anthony Caligiuri	Subtotal	1 
3031      	Liberty Harley-Davidson	Chris (Moose) Tonstad	Telephone	1 
3031      	Liberty Harley-Davidson	Chris (Moose) Tonstad	Subtotal	1 
3031      	Liberty Harley-Davidson	Michelle McTamney	Telephone	1 
3031      	Liberty Harley-Davidson	Michelle McTamney	Subtotal	1 
3031      	Liberty Harley-Davidson	Paul McGlynn	Telephone	2 
3031      	Liberty Harley-Davidson	Paul McGlynn	Subtotal	2 
3031      	Liberty Harley-Davidson	Rob Shaw	Telephone	4 
3031      	Liberty Harley-Davidson	Rob Shaw	Subtotal	4 
3031      	Liberty Harley-Davidson	Tony Bordonaro	Telephone	1 
3031      	Liberty Harley-Davidson	Tony Bordonaro	Subtotal	1 
3031      	Liberty Harley-Davidson	Vince Meehan	Telephone	4 
3031      	Liberty Harley-Davidson	Vince Meehan	Subtotal	4 
3031      	Liberty Harley-Davidson	Subtotal		34 
3031      	Subtotal			34 
3036      	H-D Of Bergen County	    	Email	1 
3036      	H-D Of Bergen County	    	Fax	13 
3036      	H-D Of Bergen County	    	Subtotal	14 
3036      	H-D Of Bergen County	Amanda Sherman	Telephone	3 
3036      	H-D Of Bergen County	Amanda Sherman	Subtotal	3 
3036      	H-D Of Bergen County	Amy  Reyes	Telephone	2 
3036      	H-D Of Bergen County	Amy  Reyes	Subtotal	2 
3036      	H-D Of Bergen County	Dave ((x 131)) Desmarais	Telephone	5 
3036      	H-D Of Bergen County	Dave ((x 131)) Desmarais	Subtotal	5 
3036      	H-D Of Bergen County	Gina Denaro	Telephone	1 
3036      	H-D Of Bergen County	Gina Denaro	Subtotal	1 
3036      	H-D Of Bergen County	Joe Bamberger	Telephone	5 
3036      	H-D Of Bergen County	Joe Bamberger	Subtotal	5 
3036      	H-D Of Bergen County	Joel Diaz	Telephone	1 
3036      	H-D Of Bergen County	Joel Diaz	Subtotal	1 
3036      	H-D Of Bergen County	Jon (parts ext 158) Kolano	Telephone	3 
3036      	H-D Of Bergen County	Jon (parts ext 158) Kolano	Subtotal	3 
3036      	H-D Of Bergen County	Ken Muso	Telephone	1 
3036      	H-D Of Bergen County	Ken Muso	Subtotal	1 
3036      	H-D Of Bergen County	Lori L'Rourke	Telephone	4 
3036      	H-D Of Bergen County	Lori L'Rourke	Subtotal	4 
3036      	H-D Of Bergen County	Louie (Lou) Manuppelli	Telephone	3 
3036      	H-D Of Bergen County	Louie (Lou) Manuppelli	Subtotal	3 
3036      	H-D Of Bergen County	Mike Sallemi	Telephone	2 
3036      	H-D Of Bergen County	Mike Sallemi	Subtotal	2 
3036      	H-D Of Bergen County	Phil (ext 35) DiGennaro	Telephone	4 
3036      	H-D Of Bergen County	Phil (ext 35) DiGennaro	Subtotal	4 
3036      	H-D Of Bergen County	Scott Muro 	Telephone	1 
3036      	H-D Of Bergen County	Scott Muro 	Subtotal	1 
3036      	H-D Of Bergen County	Vinny   (ext 126) Panissidi	Telephone	8 
3036      	H-D Of Bergen County	Vinny   (ext 126) Panissidi	Subtotal	8 
3036      	H-D Of Bergen County	Subtotal		57 
3036      	Subtotal			57 
3159      	Brooklyn Harley-Davidson Sales	Greg Barker	Telephone	7 
3159      	Brooklyn Harley-Davidson Sales	Greg Barker	Subtotal	7 
3159      	Brooklyn Harley-Davidson Sales	Joe (JB) Burgess	Telephone	3 
3159      	Brooklyn Harley-Davidson Sales	Joe (JB) Burgess	Subtotal	3 
3159      	Brooklyn Harley-Davidson Sales	Nancy (ace) Melia	Telephone	3 
3159      	Brooklyn Harley-Davidson Sales	Nancy (ace) Melia	Subtotal	3 
3159      	Brooklyn Harley-Davidson Sales	Subtotal		13 
3159      	Subtotal			13 
3174      	Prestige Harley-Davidson, Inc.	Bernie Milano	Telephone	3 
3174      	Prestige Harley-Davidson, Inc.	Bernie Milano	Subtotal	3 
3174      	Prestige Harley-Davidson, Inc.	Bill Westrick	Telephone	4 
3174      	Prestige Harley-Davidson, Inc.	Bill Westrick	Subtotal	4 
3174      	Prestige Harley-Davidson, Inc.	Carrie Goldberg	Telephone	2 
3174      	Prestige Harley-Davidson, Inc.	Carrie Goldberg	Subtotal	2 
3174      	Prestige Harley-Davidson, Inc.	Main Email/Fax	Fax	5 
3174      	Prestige Harley-Davidson, Inc.	Main Email/Fax	Subtotal	5 
3174      	Prestige Harley-Davidson, Inc.	Vince (Vinny) Grimaldi	Telephone	2 
3174      	Prestige Harley-Davidson, Inc.	Vince (Vinny) Grimaldi	Subtotal	2 
3174      	Prestige Harley-Davidson, Inc.	Subtotal		16 
3174      	Subtotal			16 
3182      	Eastern Harley-Davidson	Linda Sullivan	Telephone	2 
3182      	Eastern Harley-Davidson	Linda Sullivan	Subtotal	2 
3182      	Eastern Harley-Davidson	Main Email/Fax	Fax	4 
3182      	Eastern Harley-Davidson	Main Email/Fax	Subtotal	4 
3182      	Eastern Harley-Davidson	Michael Chornoma	Telephone	1 
3182      	Eastern Harley-Davidson	Michael Chornoma	Subtotal	1 
3182      	Eastern Harley-Davidson	Todd Stevens	Telephone	2 
3182      	Eastern Harley-Davidson	Todd Stevens	Subtotal	2 
3182      	Eastern Harley-Davidson	Subtotal		9 
3182      	Subtotal			9 
3235      	Lighthouse Harley-Davidson, Inc.	    	Fax	9 
3235      	Lighthouse Harley-Davidson, Inc.	    	Subtotal	9 
3235      	Lighthouse Harley-Davidson, Inc.	Dan Zagorski	Telephone	3 
3235      	Lighthouse Harley-Davidson, Inc.	Dan Zagorski	Subtotal	3 
3235      	Lighthouse Harley-Davidson, Inc.	Donna Lofaso	Telephone	1 
3235      	Lighthouse Harley-Davidson, Inc.	Donna Lofaso	Subtotal	1 
3235      	Lighthouse Harley-Davidson, Inc.	John Mooney	Telephone	4 
3235      	Lighthouse Harley-Davidson, Inc.	John Mooney	Subtotal	4 
3235      	Lighthouse Harley-Davidson, Inc.	Melissa Blackford	Telephone	2 
3235      	Lighthouse Harley-Davidson, Inc.	Melissa Blackford	Subtotal	2 
3235      	Lighthouse Harley-Davidson, Inc.	Paul Fardella	Telephone	4 
3235      	Lighthouse Harley-Davidson, Inc.	Paul Fardella	Subtotal	4 
3235      	Lighthouse Harley-Davidson, Inc.	Rick  Sorrentino	Telephone	1 
3235      	Lighthouse Harley-Davidson, Inc.	Rick  Sorrentino	Subtotal	1 
3235      	Lighthouse Harley-Davidson, Inc.	Rick Hawkey	Telephone	13 
3235      	Lighthouse Harley-Davidson, Inc.	Rick Hawkey	Subtotal	13 
3235      	Lighthouse Harley-Davidson, Inc.	Rob (JR) Schneider	Telephone	11 
3235      	Lighthouse Harley-Davidson, Inc.	Rob (JR) Schneider	Subtotal	11 
3235      	Lighthouse Harley-Davidson, Inc.	Rubens Deoliveiora	Telephone	4 
3235      	Lighthouse Harley-Davidson, Inc.	Rubens Deoliveiora	Subtotal	4 
3235      	Lighthouse Harley-Davidson, Inc.	Stephanie Williams	Telephone	1 
3235      	Lighthouse Harley-Davidson, Inc.	Stephanie Williams	Subtotal	1 
3235      	Lighthouse Harley-Davidson, Inc.	Subtotal		53 
3235      	Subtotal			53 
3417      	Staten Island Harley-Davidson	    	Email	2 
3417      	Staten Island Harley-Davidson	    	Subtotal	2 
3417      	Staten Island Harley-Davidson	Amanda Cenneriello	Telephone	4 
3417      	Staten Island Harley-Davidson	Amanda Cenneriello	Subtotal	4 
3417      	Staten Island Harley-Davidson	Ed White	Telephone	8 
3417      	Staten Island Harley-Davidson	Ed White	Subtotal	8 
3417      	Staten Island Harley-Davidson	eileen esposito	Telephone	4 
3417      	Staten Island Harley-Davidson	eileen esposito	Subtotal	4 
3417      	Staten Island Harley-Davidson	Fax 1	Fax	10 
3417      	Staten Island Harley-Davidson	Fax 1	Subtotal	10 
3417      	Staten Island Harley-Davidson	Gary 1	Telephone	2 
3417      	Staten Island Harley-Davidson	Gary 1	Subtotal	2 
3417      	Staten Island Harley-Davidson	Karen (X) Albrecht	Telephone	7 
3417      	Staten Island Harley-Davidson	Karen (X) Albrecht	Subtotal	7 
3417      	Staten Island Harley-Davidson	Karen Lombardi	Telephone	1 
3417      	Staten Island Harley-Davidson	Karen Lombardi	Subtotal	1 
3417      	Staten Island Harley-Davidson	Marisa Giustion	Telephone	2 
3417      	Staten Island Harley-Davidson	Marisa Giustion	Subtotal	2 
3417      	Staten Island Harley-Davidson	Mark Crescitelli	Telephone	4 
3417      	Staten Island Harley-Davidson	Mark Crescitelli	Subtotal	4 
3417      	Staten Island Harley-Davidson	Mike Lombardi	Telephone	7 
3417      	Staten Island Harley-Davidson	Mike Lombardi	Subtotal	7 
3417      	Staten Island Harley-Davidson	Subtotal		51 
3417      	Subtotal			51 
3439      	Suffolk County Harley-Davidson	Brian Giessen	Telephone	17 
3439      	Suffolk County Harley-Davidson	Brian Giessen	Subtotal	17 
3439      	Suffolk County Harley-Davidson	David Martin	Telephone	8 
3439      	Suffolk County Harley-Davidson	David Martin	Subtotal	8 
3439      	Suffolk County Harley-Davidson	Doreen  Buscarino	Telephone	1 
3439      	Suffolk County Harley-Davidson	Doreen  Buscarino	Subtotal	1 
3439      	Suffolk County Harley-Davidson	Main Email/Fax	Fax	13 
3439      	Suffolk County Harley-Davidson	Main Email/Fax	Subtotal	13 
3439      	Suffolk County Harley-Davidson	Mike Biener	Telephone	2 
3439      	Suffolk County Harley-Davidson	Mike Biener	Subtotal	2 
3439      	Suffolk County Harley-Davidson	Rick (parts) Lefebure	Telephone	10 
3439      	Suffolk County Harley-Davidson	Rick (parts) Lefebure	Subtotal	10 
3439      	Suffolk County Harley-Davidson	Subtotal		51 
3439      	Subtotal			51 
3442      	Reggie Pink, Inc.	    	Fax	3 
3442      	Reggie Pink, Inc.	    	Subtotal	3 
3442      	Reggie Pink, Inc.	Bob Dellabadia	Telephone	2 
3442      	Reggie Pink, Inc.	Bob Dellabadia	Subtotal	2 
3442      	Reggie Pink, Inc.	Janie Pink	Telephone	4 
3442      	Reggie Pink, Inc.	Janie Pink	Subtotal	4 
3442      	Reggie Pink, Inc.	Ray Zerbarini	Telephone	4 
3442      	Reggie Pink, Inc.	Ray Zerbarini	Subtotal	4 
3442      	Reggie Pink, Inc.	Subtotal		13 
3442      	Subtotal			13 
Total				552

After the macro is ran it looks a little like this:

Code:
				No Column
Dealer Number	Primary Dba Name	Caller Full Name	Channel Name	NONE
0570      	Fritz's Harley-Davidson	    	Fax	1 
		Andy (Panda) Cunningham	Telephone	7 
		Dan ((vehicle #1)) Height	Telephone	2 
		Ed Grivelrod	Telephone	1 
		Fax 2	Fax	1 
		George (Drego) Albano	Telephone	19 
		Jamie Mcgarty	Telephone	1 
		John P (Woodchuck) Narciso	Telephone	2 
		Laurie (Foof) Ferriero	Telephone	1 
		Main Email/Fax	Fax	3 
		Malone Ranalli	Telephone	1 
0570      	Subtotal			39 
1455      	Harley-Davidson of New York	    	Fax	5 
		Adam Alberghine	Telephone	30 
		Danielle Melrose	Telephone	3 
		David  Martin	Telephone	1 
		Frank Caramico	Telephone	1 
		James  (Jimmy) Holland	Telephone	2 
1455      	Subtotal			42 
1797	Harley-Davidson of Nassau County	    	Fax	11 
		Bobby C	Telephone	3 
		Byron Reich	Telephone	8 
		Dave Kohn	Telephone	2 
		Elizabeth Bergamini	Telephone	1 
		Lisa Valente	Telephone	9 
		Main Email/Fax	Fax	2 
		Michael Nicoletti	Telephone	3 
		Mike Brodsky	Telephone	2 
		Nick Palesty	Telephone	3 
		Phil Melfi	Telephone	15 
		Tim Magnuson	Telephone	1 
1797	Subtotal			60 
1972	NewRoc Harley-Davidson	    	Fax	7 
1972	NewRoc Harley-Davidson	Crissy Scopoletti	Telephone	5 
		Dave  Delio	Telephone	11 
		Dee Klein	Telephone	1 
		Email/Fax Main	Fax	3 
		Heather Webb	Telephone	1 
		Jack (917-620-0555) Meskunanus	Telephone	1 
		Jim Maguire	Telephone	2 
		John Maguire	Telephone	1 
		John Pluchino	Telephone	8 
		Minos Tzouflas	Telephone	1 
		Rob (rg@nrhd.com) Gambichler	Fax	1 
		Wayne (wayne@nrhd.com) Sforza	Telephone	3 
1972	Subtotal			45 
1998	Miracle Mile Harley-Davidson	    	Fax	1 
		Cheryl Reitano	Telephone	2 
		doug  paloscio	Telephone	1 
		Email/Fax Main	Fax	5 
		Eric Ruther	Telephone	4 
		Len (631-327-8444 cell) Campanelli	Telephone	3 
		Luciano (Lou) Jaramillo	Telephone	2 
		Phil Lynch	Telephone	1 
		Russ Cox	Telephone	9 
		Steve Ruckel	Telephone	2 
1998	Subtotal			30 
2006	Essex County Harley-Davidson	Al Molaf	Telephone	5 
		Clarence  Francis	Telephone	3 
		Ed Archambault	Telephone	2 
		Fax 2	Fax	2 
		Gene Booker	Telephone	7 
		Jay Toussaint	Telephone	4 
		Paul Barthelme	Telephone	1 
		Robert Rutland	Telephone	1 
2006	Subtotal			25 
3027      	Kosco Harley-Davidson, Inc.	    	Fax	3 
		Barry Donow	Telephone	3 
3027      	Kosco Harley-Davidson, Inc.	Denise Kosco	Telephone	2 
		Eric (parts ext 20) Loeffler	Telephone	1 
		Jason ((x. 5)) Kosco	Telephone	3 
		Rich Kosco	Telephone	2 
3027      	Subtotal			14 
3031      	Liberty Harley-Davidson	    	Fax	20 
		Anthony Caligiuri	Telephone	1 
		Chris (Moose) Tonstad	Telephone	1 
		Michelle McTamney	Telephone	1 
		Paul McGlynn	Telephone	2 
		Rob Shaw	Telephone	4 
		Tony Bordonaro	Telephone	1 
		Vince Meehan	Telephone	4 
3031      	Subtotal			34 
3036      	H-D Of Bergen County	    	Email	1 
			Fax	13 
3036      	H-D Of Bergen County	Amanda Sherman	Telephone	3 
3036      	H-D Of Bergen County	Amy  Reyes	Telephone	2 
3036      	H-D Of Bergen County	Dave ((x 131)) Desmarais	Telephone	5 
3036      	H-D Of Bergen County	Gina Denaro	Telephone	1 
3036      	H-D Of Bergen County	Joe Bamberger	Telephone	5 
3036      	H-D Of Bergen County	Joel Diaz	Telephone	1 
3036      	H-D Of Bergen County	Jon (parts ext 158) Kolano	Telephone	3 
3036      	H-D Of Bergen County	Ken Muso	Telephone	1 
3036      	H-D Of Bergen County	Lori L'Rourke	Telephone	4 
3036      	H-D Of Bergen County	Louie (Lou) Manuppelli	Telephone	3 
3036      	H-D Of Bergen County	Mike Sallemi	Telephone	2 
3036      	H-D Of Bergen County	Phil (ext 35) DiGennaro	Telephone	4 
3036      	H-D Of Bergen County	Scott Muro 	Telephone	1 
3036      	H-D Of Bergen County	Vinny   (ext 126) Panissidi	Telephone	8 
3036      	Subtotal			57 
3159      	Brooklyn Harley-Davidson Sales	Greg Barker	Telephone	7 
3159      	Brooklyn Harley-Davidson Sales	Joe (JB) Burgess	Telephone	3 
3159      	Brooklyn Harley-Davidson Sales	Nancy (ace) Melia	Telephone	3 
3159      	Subtotal			13 
3174      	Prestige Harley-Davidson, Inc.	Bernie Milano	Telephone	3 
3174      	Prestige Harley-Davidson, Inc.	Bill Westrick	Telephone	4 
3174      	Prestige Harley-Davidson, Inc.	Carrie Goldberg	Telephone	2 
3174      	Prestige Harley-Davidson, Inc.	Main Email/Fax	Fax	5 
3174      	Prestige Harley-Davidson, Inc.	Vince (Vinny) Grimaldi	Telephone	2 
3174      	Subtotal			16 
3182      	Eastern Harley-Davidson	Linda Sullivan	Telephone	2 
3182      	Eastern Harley-Davidson	Main Email/Fax	Fax	4 
3182      	Eastern Harley-Davidson	Michael Chornoma	Telephone	1 
3182      	Eastern Harley-Davidson	Todd Stevens	Telephone	2 
3182      	Subtotal			9 
3235      	Lighthouse Harley-Davidson, Inc.	    	Fax	9 
3235      	Lighthouse Harley-Davidson, Inc.	Dan Zagorski	Telephone	3 
3235      	Lighthouse Harley-Davidson, Inc.	Donna Lofaso	Telephone	1 
3235      	Lighthouse Harley-Davidson, Inc.	John Mooney	Telephone	4 
3235      	Lighthouse Harley-Davidson, Inc.	Melissa Blackford	Telephone	2 
3235      	Lighthouse Harley-Davidson, Inc.	Paul Fardella	Telephone	4 
3235      	Lighthouse Harley-Davidson, Inc.	Rick  Sorrentino	Telephone	1 
3235      	Lighthouse Harley-Davidson, Inc.	Rick Hawkey	Telephone	13 
3235      	Lighthouse Harley-Davidson, Inc.	Rob (JR) Schneider	Telephone	11 
3235      	Lighthouse Harley-Davidson, Inc.	Rubens Deoliveiora	Telephone	4 
3235      	Lighthouse Harley-Davidson, Inc.	Stephanie Williams	Telephone	1 
3235      	Subtotal			53 
3417      	Staten Island Harley-Davidson	    	Email	2 
3417      	Staten Island Harley-Davidson	Amanda Cenneriello	Telephone	4 
3417      	Staten Island Harley-Davidson	Ed White	Telephone	8 
3417      	Staten Island Harley-Davidson	eileen esposito	Telephone	4 
3417      	Staten Island Harley-Davidson	Fax 1	Fax	10 
3417      	Staten Island Harley-Davidson	Gary 1	Telephone	2 
3417      	Staten Island Harley-Davidson	Karen (X) Albrecht	Telephone	7 
3417      	Staten Island Harley-Davidson	Karen Lombardi	Telephone	1 
3417      	Staten Island Harley-Davidson	Marisa Giustion	Telephone	2 
3417      	Staten Island Harley-Davidson	Mark Crescitelli	Telephone	4 
3417      	Staten Island Harley-Davidson	Mike Lombardi	Telephone	7 
3417      	Subtotal			51 
3439      	Suffolk County Harley-Davidson	Brian Giessen	Telephone	17 
3439      	Suffolk County Harley-Davidson	David Martin	Telephone	8 
3439      	Suffolk County Harley-Davidson	Doreen  Buscarino	Telephone	1 
3439      	Suffolk County Harley-Davidson	Main Email/Fax	Fax	13 
3439      	Suffolk County Harley-Davidson	Mike Biener	Telephone	2 
3439      	Suffolk County Harley-Davidson	Rick (parts) Lefebure	Telephone	10 
3439      	Subtotal			51 
3442      	Reggie Pink, Inc.	    	Fax	3 
3442      	Reggie Pink, Inc.	Bob Dellabadia	Telephone	2 
3442      	Reggie Pink, Inc.	Janie Pink	Telephone	4 
3442      	Reggie Pink, Inc.	Ray Zerbarini	Telephone	4 
3442      	Subtotal			13 
Total				552
Code:
'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)

Hello all. I have a couple advanced conditional formatting questions that I hope someone on this forum can answer. I've done extensive searches on this forum and in books to no avail so I apologize if these have already been asked. I'm fairly a beginner to Excel so please consider in your reply.

OK, here are my questions:

1. I have a reference cell that I want all other cells to format off of. The reference cell (B3) has a formula (=INT((TODAY()-B2)/365.25)) for calulating age. Cell B6 which is blank needs a conditional format so if the age is between 10 - 18 it formats it one color and puts a check icon in the field. If it's before that range it changes the color and puts an exclamation point in and if it's greater than 18 it puts an X in.

2. On another row, if the age (reference cell) is equal to either 13, 16, 18 or 21 then I want to put a check in the box and color code the background.

If anyone can help me out with this I would be greatly appreciated as I'm totally stumped. Thanks!

Robert

A1 = 1234
A2 = 5

B1 = project 1
B2 = project 2

If I do this in C1
=concatentate(A1," ",B1)
I get
1234 project1
for C1. That's fine but doing the same thing for row 2 gets me
5 project 2

I need a way to do this (without a macro because I'm totally helpless when
it comes to macros) so that Column C lines up everything in Column A AND
everything in column B so the data is in 1 cell and the "p" in project lines
up vertically no matter how many characters are in the number in Column A.
The data HAS TO be in a single cell - no merging cells and changing border
colors to make it appear that way.
I think I need something in my concatenate that assigns a set number of
spaces to the data in Column A and concatenates Column B data starting in
the same position every time.
But how?

I have a spreadsheet with a total amount, account number, account
name, and two different cash amounts. I want to set up a CF but I
need it in VBA because the information gets imported and erases the CF
otherwise. What I want is for the corresponding row in columns A, B,
C, D and E to change to red and bold if either of the values in Column
F and G are

Let's say in D55 on each sheet is a formula showing a cumulative total from
the prior sheets

If the cumulative total in D55 is less than 40, I'd like cells in rows 1
through 49 to be green, if over 40, turn the cells red.

In other words, can I make the condition formating dependant on a totally
different cell?

There's a nice booksamillion right down the street - I'll be checking
that in the next week or so.

Does anyone have some good online references for vbscripts in Excel?

I'm somewhat familiar with programming - here is what I wish to
accomplish.

Below is some table data - I've added the rows and columns for
reference.
----------------------------

A B C D

Negative Date
Quantity Last
1 Location On Hand < 0 Leader Upd
------------------------------------------------------------------
2 Store 01 0 2 Date
3 Store 02 33 |
4 Store 03 85 |
5 Store 04 2 1 V
6 Store 05 6 2
7 Store 07 18
8 Store 08 15 1
9 Store 10 32
10 Store 11 1 2
11 Store 20 24
12 Store RO 184
13 Warehouse 12
------------------------------------------------------------------
14 Total Negative Quantity Items 412

Once per day, I refresh the data of the table (which updates the
negative quantity on hand counts). The negative quantity leader (NQL
from here on) column does not change with the refreshing of the data
(yet). I'm physically incrementing the NQL by 1 each day. I just know
there's a way to automatically update that column's count with some VB
scripting... I just am not familiar enough with that side of excel to
impelment it.

Here's the algorithm I put together.
-----

Refresh the worksheet data at 11:00am
Negative quantity counts update to reflect current numbers
Check to see if the date in column D reflects today's date
If not, Update Column D to reflect today's date, if
so end.
Check to see whether values in column B2-B13
are less than or equal to 10
If not, color the contents of the cell
black, if so, add 1 to the count in column C color the text red

-----

Mainly I want to be able to refresh the table any time during the day to
show how many negative quantity items exist at each store (this checks
inventory counts through a database), but once a day (at 11am) I want to
have the worksheet refresh the last column so I can send out a pat on
the back to my stores through e-mail.

Is this fairly simple? Complex? Any help of course would be
appreciated.

Can anyone help with any, some, or all of these steps?

In my sheet, this is what needs to happen (in my mind of course):

First, ignore the colored portions. This is how I kept track of what I had completed in the form as I created it. Clients attend class once a week and pay once a week for their classes.

Top column: Report for week (every Monday's date)

First Row = Name of client (this same name when entered in the "5groups" sheet, will automatically be entered into the corresponding class sheet)

Second Row = I will enter the number of classes required by the court

Third Row = when they attend their class, they will be marked "present" in the correct sheet, thus adding +1 to their classes attended so far. I need the number of classes to become cumulative; therefore every time they are present in class, it adds 1 to this column (at the bottom of this explanation, you will see how this would ideally happen without adding additional sheets).

Fourth Row = Classes required minus classes attended equals classes remaining

Fifth Row = When they make a payment, this number should increase accordingly so we can track how many classes they have paid for

Sixth Row = Nothing fancy, this is their probation number

Seventh Row = We will enter the fee due for each class manually based on their income level and fee tier

Eight Row = Minimum payment due:

o When "amount paid" equals "payment per session" set "minimum payment due" to $0 and increase "classes paid" by +1

o When "amount paid" equals less than "payment per session" set "minimum payment due" to (what the remaining amount is) and do NOT increase "classes paid" until they catch up on payments to equal $0 on "minimum payment due" and then the above bullet would happen (only increase classes paid by +1 when the amount paid = payment per session) Example: Johnny has to pay $10/session. He does not pay this week or next week. Minimum payment due is now $20. He pays $15 and still owes $5. Minimum due = $5, but classes paid increased by 1 because he met the $10/session minimum. When he pays the remaining $5, classes will increase by 1.

o When "amount paid" equals greater than "payment per session" set "minimum payment due" to reflect the [credit] and increase "classes paid" accordingly

Ninth Row = the amount they are paying this week (we enter this number upon receipt of payment)

Special Notes:

Every Monday the date of "Report for week beginning" to reflect that Monday's date.

Every Monday the "minimum payment due" should reset to the same as "payment per session" without affecting the rest of the columns. If there is a balance due, that would be added, if there is a credit, it would be deducted

Every Monday the roster sheet resets, without changing the “classes attended” column total and continuing to keep count.

Should I start by doing this one step at a time?


No luck finding an answer? You could always try Google.