Solved

VBA formatting from Array

Posted on 2013-10-28
8
283 Views
Last Modified: 2013-11-03
I would like to know the best way to have the attached report generate from an Array I have filled.  In the first table I put the array values in the fields they would fill.  The table headings would remain constant.  I am using the SSN as a unique ID to determine when a new table would start with Array(i).SupName.  Any help would be greatly appreciated.

MartinLiss, I am using the array format you taugh me for this.
Supervisor-Breakout.xlsx
0
Comment
Question by:Chrispy2811
  • 6
  • 2
8 Comments
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
I'm sorry but I don't understand the question? What array are you referring to?
0
 
LVL 2

Author Comment

by:Chrispy2811
Comment Utility
Where you load everything into a public
Type. Like you told me I'm this question. http://mobile.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28171277.html
0
 
LVL 2

Author Comment

by:Chrispy2811
Comment Utility
I want to know how to get something like the attached spreadsheet to be displayed from an array of information. Long ago I would have used crystal reports but that's not an option ever in vba
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
Okay even though I helped you with that it's a lot to look through. Do you have a workbook that shows the data from which you want to generate the report? And what kind of "report" do you want? A printed worksheet or...?
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 2

Author Comment

by:Chrispy2811
Comment Utility
I have attached a new excel file.  I need a report to print on a worksheet like I have provided.  This will come when the module "SupRosterBreakout" is called.  I have included the 3 modules used to generate the informaion to fill the worksheet.  Let me know if this helps thanks.
Supervisor-Breakout.xlsm
0
 
LVL 2

Author Comment

by:Chrispy2811
Comment Utility
I got the report to print out the way I want I am just working on the formatting now.  See attached code.  There are comments on how the formatting is needed if you still would like to help on that portion.
Sub GenBreakoutRoster()
    Dim memberCount As Integer
    Dim SupName As String, SelectedSupName As String
    Dim SupNameLen As Integer, SelectedSupNameLen As Integer
    Dim xTroop As Integer   'increment the supervisor array
    xTroop = 0

    Dim SupIDKey As String  'This is the place holder for the SupID in the ArraySupRosterBreakout will be SSN
    Dim SupFullName As String    ' This will have the Sup Name and Rank for the heading

    LoadArray.LoadAlphaRosterArray
    Sheet4.Activate
    memberCount = Cells(Rows.count, "A").End(xlUp).Row
    ReDim ArraySupRosterBreakout(memberCount)

    For X = LBound(ArrayMemberData) To UBound(ArrayMemberData)
        SupIDKey = ArrayMemberData(X).SSAN
        SupFullName = ArrayMemberData(X).Grade & " " & ArrayMemberData(X).Full_Name
        SelectedSupName = ArrayMemberData(X).Full_Name
        SelectedSupName = UCase(Replace(SelectedSupName, " ", ""))
        SelectedSupName = Replace(SelectedSupName, ",", "")
        SelectedSupNameLen = Len(SelectedSupName)

        For i = LBound(ArrayMemberData) To UBound(ArrayMemberData)
            SupName = ArrayMemberData(i).Supv_Name
            SupName = UCase(Replace(SupName, " ", ""))
            SupName = Replace(SupName, ",", "")
            SupNameLen = Len(SupName)

            If SupNameLen <> 0 Then
                If Left(SupName, SupNameLen) = Left(SelectedSupName, SupNameLen) Then
                    ArraySupRosterBreakout(xTroop).SupID = SupIDKey
                    ArraySupRosterBreakout(xTroop).SupName = SupFullName
                    ArraySupRosterBreakout(xTroop).TroopRank = ArrayMemberData(i).Grade
                    ArraySupRosterBreakout(xTroop).TroopName = ArrayMemberData(i).Full_Name
                    ArraySupRosterBreakout(xTroop).SupStartDate = ArrayMemberData(i).Supv_Begin_Date
                    ArraySupRosterBreakout(xTroop).NoDaySup = CDate(Date) - CDate(ArrayMemberData(i).Supv_Begin_Date)    ' number of days under current supervision
                    ArraySupRosterBreakout(xTroop).NoDaySupDEROS = CDate(ArrayMemberData(X).DEROS) - CDate(ArrayMemberData(i).Supv_Begin_Date)  ' add the time between SupStartDate and DEROS of SUP
                    ArraySupRosterBreakout(xTroop).EPRCloseout = ArrayMemberData(i).Proj_Eval_Close_Date
                    ArraySupRosterBreakout(xTroop).DaysUntilCloseout = CDate(ArrayMemberData(i).Proj_Eval_Close_Date) - CDate(Date)    'days until closeout
                    ArraySupRosterBreakout(xTroop).DutyTitle = ArrayMemberData(i).Duty_Title
                    ArraySupRosterBreakout(xTroop).SupDEROS = ArrayMemberData(X).DEROS
                    xTroop = xTroop + 1
                End If
            End If
        Next i
    Next X

    'Temp solution for filling the roster to sendout
    Sheet18.Activate
    Dim trigger As Integer    ' tells when the supervisor changes and when to start a new table
    Dim t As Integer    ' ArraySupRosterBreakout indexer
    Dim txCountLocation As Integer
    Dim txCount As Integer    ' number of troops under each sup.
    'this is added to the t count to get the next sup as well.
    X = 1
    txCount = 0
    For t = LBound(ArraySupRosterBreakout) To UBound(ArraySupRosterBreakout)
        'all cells down to first x = x+1 should be Bold font
        Cells(X, 1).Value = ArraySupRosterBreakout(t).SupName    '<-- filled yellow background
        Cells(X, 2).Value = "Number of Troops:"
        txCountLocation = X    ' this will store the location the txCount value will go to add total troop count Cells(X, 3).Value = "XX"    ' ADD THE NUMBER OF TIMES THE TROOPS CYCLE RUNS.
        Cells(X, 5).Value = "DEROS"
        Cells(X, 6).Value = ArraySupRosterBreakout(t).SupDEROS
        'Constant cells headings
        X = X + 1
        ' The below 7 lines need to be bold, filled gray, thick line border all sides
        Cells(X, 1).Value = "Name"
        Cells(X, 2).Value = "Supervision Start Date"
        Cells(X, 3).Value = "# Days Supervised"
        Cells(X, 4).Value = "# Days Supervised at DEROS"
        Cells(X, 5).Value = "EPR Closeout"
        Cells(X, 6).Value = "Days Until Closeout"
        Cells(X, 7).Value = "Duty Title"
        X = X + 1
        'run through each entry to see if supid matches the above sup
        'tx stands for troop from above and x var
        txCount = 0
        For tx = LBound(ArraySupRosterBreakout) To UBound(ArraySupRosterBreakout)
            If ArraySupRosterBreakout(tx).SupID = ArraySupRosterBreakout(t).SupID Then
                'format odd and even for fill no fill, count times this is run for troop count at top of table
                'add a switch if even fill color gray
                'all cells will have border of think line on both sides
                'last cell in list will have border thick line on bottom

                Cells(X, 1).Value = ArraySupRosterBreakout(tx).TroopRank & " " & ArraySupRosterBreakout(tx).TroopName
                Cells(X, 2).Value = ArraySupRosterBreakout(tx).SupStartDate
                Cells(X, 3).Value = ArraySupRosterBreakout(tx).NoDaySup
                Cells(X, 4).Value = ArraySupRosterBreakout(tx).NoDaySupDEROS
                Cells(X, 5).Value = ArraySupRosterBreakout(tx).EPRCloseout
                Cells(X, 6).Value = ArraySupRosterBreakout(tx).DaysUntilCloseout
                Cells(X, 7).Value = ArraySupRosterBreakout(tx).DutyTitle
                X = X + 1
                txCount = txCount + 1
            End If
        Next tx
        Cells(txCountLocation, 3).Value = txCount


        X = X + 1
        t = t + txCount
    Next t
End Sub

Open in new window

0
 
LVL 2

Accepted Solution

by:
Chrispy2811 earned 0 total points
Comment Utility
Here is the final code I used to included formatting.  Its not clean so if anyone wants to clean it up be my guest.

Sub GenBreakoutRoster()
' ------only need the below if you are not opening in a new workbook
    Sheet19.Activate
    Cells.Select
    Selection.Delete
    Dim memberCount As Integer
    Dim SupName As String, SelectedSupName As String
    Dim SupNameLen As Integer, SelectedSupNameLen As Integer
    Dim xTroop As Integer   'increment the supervisor array
    xTroop = 0

    Dim SupIDKey As String  'This is the place holder for the SupID in the ArraySupRosterBreakout will be SSN
    Dim SupFullName As String    ' This will have the Sup Name and Rank for the heading

    LoadArray.LoadAlphaRosterArray
    Sheet4.Activate
    memberCount = Cells(Rows.count, "A").End(xlUp).Row
    ReDim ArraySupRosterBreakout(memberCount)

    For x = LBound(ArrayMemberData) To UBound(ArrayMemberData)
        SupIDKey = ArrayMemberData(x).SSAN
        SupFullName = ArrayMemberData(x).Grade & " " & ArrayMemberData(x).Full_Name
        SelectedSupName = ArrayMemberData(x).Full_Name
        SelectedSupName = UCase(Replace(SelectedSupName, " ", ""))
        SelectedSupName = Replace(SelectedSupName, ",", "")
        SelectedSupNameLen = Len(SelectedSupName)

        For i = LBound(ArrayMemberData) To UBound(ArrayMemberData)
            SupName = ArrayMemberData(i).Supv_Name
            SupName = UCase(Replace(SupName, " ", ""))
            SupName = Replace(SupName, ",", "")
            SupNameLen = Len(SupName)

            If SupNameLen <> 0 Then
                If Left(SupName, SupNameLen) = Left(SelectedSupName, SupNameLen) Then
                    ArraySupRosterBreakout(xTroop).SupID = SupIDKey
                    ArraySupRosterBreakout(xTroop).SupName = SupFullName
                    ArraySupRosterBreakout(xTroop).TroopRank = ArrayMemberData(i).Grade
                    ArraySupRosterBreakout(xTroop).TroopName = ArrayMemberData(i).Full_Name
                    ArraySupRosterBreakout(xTroop).SupStartDate = ArrayMemberData(i).Supv_Begin_Date
                    ArraySupRosterBreakout(xTroop).NoDaySup = CDate(Date) - CDate(ArrayMemberData(i).Supv_Begin_Date)    ' number of days under current supervision
                    ArraySupRosterBreakout(xTroop).NoDaySupDEROS = CDate(ArrayMemberData(x).DEROS) - CDate(ArrayMemberData(i).Supv_Begin_Date)  ' add the time between SupStartDate and DEROS of SUP
                    ArraySupRosterBreakout(xTroop).EPRCloseout = ArrayMemberData(i).Proj_Eval_Close_Date
                    ArraySupRosterBreakout(xTroop).DaysUntilCloseout = CDate(ArrayMemberData(i).Proj_Eval_Close_Date) - CDate(Date)    'days until closeout
                    ArraySupRosterBreakout(xTroop).DutyTitle = ArrayMemberData(i).Duty_Title
                    ArraySupRosterBreakout(xTroop).SupDEROS = ArrayMemberData(x).DEROS
                    ArrayMemberData(i).Row = "1"
                    xTroop = xTroop + 1
                End If

            End If
        Next i
    Next x

    'Temp solution for filling the roster to sendout
    Sheet19.Activate


    Dim trigger As Integer    ' tells when the supervisor changes and when to start a new table
    Dim t As Integer    ' ArraySupRosterBreakout indexer
    Dim txCountLocation As Integer
    Dim txCount As Integer    ' number of troops under each sup.
    'this is added to the t count to get the next sup as well.
    x = 1
    txCount = 0
    For t = LBound(ArraySupRosterBreakout) To UBound(ArraySupRosterBreakout)
        'Highlight Supervisor and make them BOLD
        Cells(x, 1).Value = ArraySupRosterBreakout(t).SupName

        If ArraySupRosterBreakout(t).SupName = "" Then
            txCountLocation = x
            Cells(x, 2).Value = "Number of Troops: "
            Cells(x, 2).Font.Bold = True
            Cells(x, 2).HorizontalAlignment = xlRight
            x = x + 1
            GoTo NoSup
        End If
        Cells(x, 1).Interior.Color = 65535
        Cells(x, 1).Font.Bold = True

        'Bold Cell and right aligin text
        Cells(x, 2).Value = "Number of Troops: "
        Cells(x, 2).Font.Bold = True
        Cells(x, 2).HorizontalAlignment = xlRight

        'Bold Cell and right aligin text
        Cells(x, 5).Value = "DEROS: "
        Cells(x, 5).Font.Bold = True
        Cells(x, 5).HorizontalAlignment = xlRight

        'Bold Cell and left aligin text
        Cells(x, 6).Value = ArraySupRosterBreakout(t).SupDEROS
        Cells(x, 6).Font.Bold = True
        Cells(x, 6).HorizontalAlignment = xlLeft

        ' this will store the location the txCount value will go to add total troop count Cells(X, 3).Value = "XX"    ' ADD THE NUMBER OF TIMES THE TROOPS CYCLE RUNS.
        txCountLocation = x

        'Constant cells headings
        x = x + 1
        ' The below 7 lines need to be bold, filled gray, thick line border all sides
        Cells(x, 1).Value = "Name"
        Cells(x, 2).Value = "Supervision Start Date"
        Cells(x, 3).Value = "# Days Supervised"
        Cells(x, 4).Value = "# Days Supervised at DEROS"
        Cells(x, 5).Value = "EPR Closeout"
        Cells(x, 6).Value = "Days Until Closeout"
        Cells(x, 7).Value = "Duty Title"
        Range(Cells(x, 1), Cells(x, 7)).Select
        Selection.Font.Bold = True
        Selection.Interior.Color = 8421504

        With Selection.Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With

        'dump names with no supervisor
NoSup:
        x = x + 1
        'run through each entry to see if supid matches the above sup
        'tx stands for troop from above and x var
        txCount = 0


        For tx = LBound(ArraySupRosterBreakout) To UBound(ArraySupRosterBreakout)
            If ArraySupRosterBreakout(tx).SupID = ArraySupRosterBreakout(t).SupID Then
                'format odd and even for fill no fill, count times this is run for troop count at top of table
                'add a switch if even fill color gray
                'all cells will have border of think line on both sides
                'last cell in list will have border thick line on bottom

                Cells(x, 1).Value = ArraySupRosterBreakout(tx).TroopRank & " " & ArraySupRosterBreakout(tx).TroopName
                Cells(x, 2).Value = ArraySupRosterBreakout(tx).SupStartDate
                Cells(x, 3).Value = ArraySupRosterBreakout(tx).NoDaySup
                
                'highlight 120 days supervision or more EPR Required
                If Cells(x, 3).Value >= 120 Then
                    Cells(x, 3).Select
                    With Selection
                        .Font.Bold = True
                        .Font.Underline = xlUnderlineStyleSingle
                    End With
                End If
                
                Cells(x, 4).Value = ArraySupRosterBreakout(tx).NoDaySupDEROS
                Cells(x, 5).Value = ArraySupRosterBreakout(tx).EPRCloseout
                Cells(x, 6).Value = ArraySupRosterBreakout(tx).DaysUntilCloseout
                  If Cells(x, 6).Value < 0 Then
                    Cells(x, 6).Font.Bold = True
                    Cells(x, 6).Select
                    With Selection.Interior
                        .Color = 255
                    End With
                End If
                Cells(x, 7).Value = ArraySupRosterBreakout(tx).DutyTitle

                Range(Cells(x, 1), Cells(x, 7)).Select
                'If an odd row shade it light gray
                If IsOdd(txCount) Then
                    Selection.Interior.Color = 14540253
                End If
                'add borders to both sides of the table
                With Selection.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                    .ColorIndex = xlAutomatic
                End With

                With Selection.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                    .ColorIndex = xlAutomatic
                End With

                With Selection.Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                    .ColorIndex = xlAutomatic
                End With

                x = x + 1
                txCount = txCount + 1

            End If

        Next tx

        'Add a border to the bottom of the last row using the last x value
        Range(Cells(x, 1), Cells(x, 7)).Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With

        'Format cell to BOLD and align left to match above formatting
        Cells(txCountLocation, 3).Value = txCount
        Cells(txCountLocation, 3).Font.Bold = True
        Cells(txCountLocation, 3).HorizontalAlignment = xlLeft

        x = x + 1
        t = t + txCount
    Next t
    'List all members who do not have a supervisor listed on our Alpha Roster
    x = Cells(Rows.count, 7).End(xlUp).Row

    'Autofit Col without long heading for "No Supervisors".
    Columns("A:A").ColumnWidth = 28.43
    Columns("A:A").ColumnWidth = 33
    Columns("A:A").EntireColumn.AutoFit    'ColumnWidth = 29.71
    Columns("B:B").EntireColumn.AutoFit    'ColumnWidth = 19.71
    Columns("C:C").EntireColumn.AutoFit    'ColumnWidth = 16.14
    Columns("D:D").EntireColumn.AutoFit    'ColumnWidth = 24
    Columns("D:D").EntireColumn.AutoFit    'ColumnWidth = 25.29
    Columns("D:D").EntireColumn.AutoFit    'ColumnWidth = 24.43
    Columns("E:E").EntireColumn.AutoFit    'ColumnWidth = 11.86
    Columns("F:F").EntireColumn.AutoFit    'ColumnWidth = 17.57
    Columns("G:G").EntireColumn.AutoFit

    x = x + 2
    Cells(x, 1).Value = "Members without Supervisors listed in our squadron"
    Cells(x, 2).Value = "Number of troops:"
    Cells(x, 3).Value = ""
    Cells(x, 4).Value = ""
    Cells(x, 5).Value = ""
    Cells(x, 6).Value = ""
    Cells(x, 7).Value = ""


    'Add the table headers for members with no supervisor
    'Cells(X, 1).Value = "Rank and Name"
    'Cells(X, 2).Value = "Date Arrive @ Osan"
    'Cells(X, 3).Value = "Supervisor"
    'Cells(X, 4).Value = "Duty Title"

    
    Dim noSups As Integer, xCountLocation As Integer
    noSups = 0
    xCountLocation = x
    x = x + 1
    For i = LBound(ArrayMemberData) To UBound(ArrayMemberData)
        If ArrayMemberData(i).Row <> "1" Then
            Cells(x, 1).Value = ArrayMemberData(i).Grade & " " & ArrayMemberData(i).Full_Name
            Cells(x, 2).Value = ArrayMemberData(i).Date_Arrived_Station
            Cells(x, 4).Value = ArrayMemberData(i).Supv_Name
            Cells(x, 7).Value = ArrayMemberData(i).Duty_Title
            x = x + 1
            noSups = noSups + 1
        End If
    Next i
    Cells(xCountLocation, 3).Value = noSups
End Sub

Function IsOdd(x As Integer) As Boolean
    IsOdd = (x Mod 2) <> 0
End Function

Open in new window

0
 
LVL 2

Author Closing Comment

by:Chrispy2811
Comment Utility
I was able to work through the issue I was having without help from EE members
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

7 Experts available now in Live!

Get 1:1 Help Now