3
\$\begingroup\$

Revised and truncated version of my last question. I updated how I handle the error if a cost center is not found. I originally asked expecting improvements on the matching system so thoughts on that will also be appreciated. Finally, interested in improvements to the looping part to determine first blank cell to drop data (the line starting with For y = 0 To 99).

Of course, surprise me with things I don't even think about ^_^;

Sub transfer()

Dim actualsWS As Worksheet
Dim fromWS As Worksheet
Dim inputMonth As Integer
Dim month As String
Dim loc As Range
Dim start As Integer
Dim rowCol As Variant
Dim dropRow As Integer
Dim dropCol As Integer
Dim locActual As Range

'store worksheets into variables
Set actualsWS = ThisWorkbook.Worksheets("Actuals by Month")
Set fromWS = ThisWorkbook.Worksheets("FAS Data Entry")

MsgBox ("If macro dies, it's likely a missing cost center.") 'warning for user

inputMonth = InputBox(prompt:="What month?") 'prompt user for current month
month = ToMonthName(inputMonth) 'call function to turn number into string
If month = vbNullString Then 'if bad month, quit sub
    MsgBox ("bad month")
    Exit Sub
End If

With fromWS 'data entry tab

    Set loc = .Cells.Find(month) 'locate starting range for current month

    'check previous row for carried over month (revising asset) Will break if 2 or more
    If loc.Offset(-1, 0) = "" Then 'if previous row is blank
        start = loc.row 'starting row is same row as found location above
    Else
        start = loc.row - 1 'else it's 1 row above
    End If

    i = 0
    Dim data As Collection
    Set data = New Collection

    Do While .Cells(start + i, 1) <> vbNullString 'loop through column A while there is a month present (not blank)

        'passes entire row to function then add it to collection
        data.Add ReadModel(.Range("A" & start + i).EntireRow)
        i = i + 1

    Loop

End With

With actualsWS 'actuals tab

    .Columns("V:W").ClearContents 'clear previous data

    'hide unnecessary months
    If month = "January" Or month = "February" Or month = "March" Or month = "April" Then
        .Columns("M:Q").EntireColumn.Hidden = True
    End If

    Dim item As DataModel
    Dim failed As Collection
    Set failed = New Collection

    'drop data into respective cells onto "actuals by month" tab
    For Each item In data 'each collection item is a class object

        Set locActual = .Cells.Find(item.CostCenter) 'find cost center location
        If Not locActual Is Nothing Then 'if found
            dropRow = .Range(locActual.Address).row 'store row of cost center

            'for loop to find first empty cell to drop into
            For y = 0 To 99 'no cost center should have over 99 rows

                If .Cells(dropRow + y, 22).value = "" Then 'column v blank
                    .Cells(dropRow + y, 22).value = item.Amount 'drop amount
                    .Cells(dropRow + y, 22).Offset(0, 1).value = item.Description 'drop description on row below
                    Exit For
                End If

            Next
        Else 'if not found
            failed.Add item.CostCenter 'add it to failed collection
        End If
    Next

    actualsWS.Cells(8, 22).Select 'bring cursor to top

    Dim message As String
    For Each e In failed 'loop through collection to store all failed cost centers into one variable
        message = message & e & vbNewLine
    Next

    MsgBox message, , "cost centers not found" 'display all unfound cost centers
End With

Public Function ToMonthName(ByVal value As Integer) As String
'takes number entered by user and converts it to string
On Error GoTo CleanFail

Dim result As String
result = MonthName(value)

CleanExit:
    ToMonthName = result
    Exit Function
CleanFail:
    result = vbNullString
    Resume CleanExit
End Function

Private Function ReadModel(ByVal source As Range) As DataModel 'returns our class

'row of data from data entry tab gets passed in
Dim result As New DataModel 'create an object of our class
'let each class attribute pertain to the corresponding column from row
result.CostCenter = source.Cells(1, 11).value
result.Amount = source.Cells(1, 13).value
result.Description = source.Cells(1, 9).value
Set ReadModel = result 'set function to equal our class object

End Function

Class Module

Option Explicit

'class to contain cost center, description and amount
Private Type TModel
    CostCenter As String
    Description As String
    Amount As Single
End Type

Private this As TModel

Public Property Get CostCenter() As String
    CostCenter = this.CostCenter
End Property

Public Property Let CostCenter(ByVal value As String)
    this.CostCenter = value
End Property

Public Property Get Description() As String
    Description = this.Description
End Property

Public Property Let Description(ByVal value As String)
    this.Description = value
End Property

Public Property Get Amount() As Single
    Amount = this.Amount
End Property

Public Property Let Amount(ByVal value As Single)
    this.Amount = value
End Property
\$\endgroup\$
  • 3
    \$\begingroup\$ Why truncated? Give us all you've got! =) \$\endgroup\$ – Mathieu Guindon Jun 21 '16 at 19:48
  • 4
    \$\begingroup\$ Yea but now Zak will see I only applied 1% of his advice XD \$\endgroup\$ – findwindow Jun 21 '16 at 19:53
  • \$\begingroup\$ If you haven't implemented the changes, they will just be recommended again.. which is wasting both your time and our time. Make the changes you feel you need, explain why you didn't do what you didn't do and give us the entire thing. \$\endgroup\$ – Raystafarian Jun 22 '16 at 10:58
  • \$\begingroup\$ I started to edit OP explaining changes I didn't make then canceled it. I am not a programmer and will likely never be one nor do I work with programmers. So my code is really just for me. I changed answer because it made sense to do so but kept actualsWS because that makes sense to me as is. I am on SO/CR because I am interested in programming concepts such as class, encapsulation, error handling, architecture. Stuff that directly pertains to the operation of the code. Readability for other/subsequent users doesn't apply to me. \$\endgroup\$ – findwindow Jun 22 '16 at 16:30
  • \$\begingroup\$ None of my code is super long/complex so if my future me forgets/confused, it won't be too hard to figure out what past me did XD \$\endgroup\$ – findwindow Jun 22 '16 at 16:34
3
\$\begingroup\$

This function will either return "" or the name of month.

Function getMonth() As String
    Dim msg As String
    Dim m As String
    Dim i As Integer
    msg = "What Month?"
    For i = 1 To 12
        msg = msg & vbCrLf & i & " - " & MonthName(i)
    Next

    i = Application.InputBox(msg, "Choose a Month", month(Date), , , , , 1)

    If i > 0 Then getMonth = MonthName(i)
End Function

ReadModel(.Range("A" & start + i).EntireRow)

ReadModel is miss leading.

  • getModel()
  • getNewModel()
  • createModel()
  • getModelFromRow()

Replace .Range("A" & start + i).EntireRow with .Rows(i)

The failed collection is not necessary.

Dim failed As Collection

If you are planning on using the data collection elsewhere, add a Found property to your DataModel.

Private Type TModel
    CostCenter As String
    Description As String
    Amount As Single
    Found as Boolean
End Type

If you are not going to reuse the data collection, just remove the items form data as you find them.

item.Remove data Is this your Output:

Actuals by Month

Cost Center | Item Amount | Item Description Janitorial

.....Possibly 99 blank rows later Front Office
$45.00 12 Reams Standard Letter Size $10.34 24 Red Pens $23.56 1 Case Sticky Pads .....Possibly 96 blank rows later Sales Dept $45.00 12 Reams Standard Letter Size $123.99 10 Cases Type 2 Invoices .....Possibly 97 blank rows later Facilities

.....Possibly 99 blank rows later

Couldn't this be achieved by filtering your FAS Data Entry by month and applying standard Excel grouping and subtotaling techniques?

I would recommend clearing the Cost Centers off of the [Actuals by Month] and writing them in from row 1 as you iterate through the data collection. If you need a complete list of Cost Centers, simply add them to the data collection in your initial loop.

\$\endgroup\$
  • \$\begingroup\$ The month function is good. Clever even but what Mat had suffices. (And I like it because it taught me error handling.) The naming and the part about excel subtotals are good. The latter I can't do because this workbook contains a dozen sheets which all tie together. I would have to rearchitect everything. My boss would kill me. \$\endgroup\$ – findwindow Jun 22 '16 at 16:42
  • \$\begingroup\$ Now, the part about not needing a second collection and reusing the original.... brilliant ^__^ \$\endgroup\$ – findwindow Jun 22 '16 at 16:43
  • \$\begingroup\$ Thanks! I understand we all get stuck dealing with legacy. The majority of VB code that I see is needed because manages and end users are afraid of change. \$\endgroup\$ – user109261 Jun 22 '16 at 19:33
  • \$\begingroup\$ Just realized that the found property would require another class? Because I would need to do item.costcenter.found right? Edit: or I guess it's easier to key the collection instead. \$\endgroup\$ – findwindow Jun 22 '16 at 20:34
  • \$\begingroup\$ I'm writing an edit now. What column are Cost Centers on in the Acuals worksheet? \$\endgroup\$ – user109261 Jun 22 '16 at 21:20
2
\$\begingroup\$

I don't like updating the Call Centers month by month and think that all the data should be cleared from the Actual's worksheet and then updated. I would then add each Cost Center and their items to the Actual's worksheet.

Because I don't know what other information is stored on the Actual's worksheet, here is how I think that it should be done.

Like Mat's Mug I believe that the uses of Enumerations makes your code easier to read, debug and modify.

Column's Enumeration

Public Enum ColumnPosition
    MonthColumn = 8 ' FAS Data Entry Month Column
    DescriptionColumn = 9
    CostCenterColumn = 11
    AmountColumn = 13
    FirstMonth = 8 ' Actuals by Month
End Enum

DataItem Class

Option Explicit

Private arrData

Private Sub Class_Initialize()
    ReDim arrData(12, 0)
End Sub

Public Sub AddItem(sMonthName As String, Description As String, Amount As Single)
    Dim i As Integer, m As Integer

    m = getMonthIndex(sMonthName)
    Debug.Print sMonthName, m

    i = getEmtpyRow(m)
    arrData(m, i) = Amount

    i = getEmtpyRow(m)
    arrData(m, i) = Description

End Sub

Private Function getMonthIndex(sMonthName As String) As Integer
    getMonthIndex = month("01-" & sMonthName & "-1900") - 1
End Function

Private Function getEmtpyRow(m As Integer) As Long
    Dim i As Integer, iRow As Integer
    iRow = -1
    For i = 0 To getSize
        If IsEmpty(arrData(m, i)) Then
            iRow = i
        End If
    Next

    If iRow = -1 Then
        iRow = getSize + 1
        ReDim Preserve arrData(12, iRow)
    End If

    getEmtpyRow = iRow
End Function

Public Function getSize()
    getSize = UBound(arrData, 2)
End Function

Public Sub PasteValues(Destination As Range)
    Destination.Resize(getSize + 1, 12) = WorksheetFunction.Transpose(arrData)
End Sub

Collect the Call Centers using a Scripting Dictionary

Iterates over the FAS Data Entry collecting dataitems in a dictionary of Cost Centers. As data is added to a dataitem it is stored in a 12 dimensional array corresponding to the month of the data.

Function getCallCenterItems()
    Dim sMonthName As String, CostCenter As String, Description As String, Amount As Single
    Dim i As Integer, lastRow As Long
    Dim DataItems
    Dim item As DataItem

    With ThisWorkbook.Worksheets("FAS Data Entry")
        lastRow = .Cells(rowS.Count, MonthColumn).End(xlUp).Row
        For i = 2 To lastRow
            sMonthName = Cells(i, MonthColumn)
            CostCenter = Cells(i, CostCenterColumn)
            Amount = Cells(i, AmountColumn)
            Description = Cells(i, DescriptionColumn)

            If DataItems.Exists(CostCenter) Then
                Set item = DataItems(CostCenter)
            Else
                Set item = New DataItem
                DataItems.Add CostCenter, item
            End If

            item.AddItem sMonthName, Description, Amount
        Next i
    End With
    Set DataItems = CreateObject("Scripting.Dictionary")
End Function

Update the Call Centers

Here we find each Cost Centers in the dictionary and use item.PasteValues (.Cells(locActual.Row, FirstMonth)) to transpose the data collected for all the year. In this way, there is no need to ask for user input.

Sub UpdateCallCenters()
    Dim DataItems As Dictionary
    Dim item As DataItem
    Dim CostCenter As Variant, msg As String
    Dim locActual As Range
    Set DataItems = getCallCenterItems

    With ThisWorkbook.Worksheets("Actuals by Month")
        .Range(.Cells(2, FirstMonth), .Cells(2, FirstMonth + 12)).ClearContents

        For Each CostCenter In DataItems.Keys
            Set locActual = .Cells.Find(CostCenter)
            Set item = DataItems(CostCenter)
            item.PasteValues (.Cells(locActual.Row, FirstMonth))
            DataItems.Remove CostCenter
        Next
    End With

    For Each CostCenter In DataItems.Keys
       msg = msg & vbCrLf & CostCenter
    Next

    If Len(msg) Then
        MsgBox msg, vbInformation, "Cost Centers Not Found"
    End If

End Sub
\$\endgroup\$
  • \$\begingroup\$ I should just stick with SO. Don't understand the entire thing but my question was about error checking which you seem to have disregarded. The issue with dictionary is that you assume a cost center only happens once. The array covers all year but only one row? If so, pastevalues will just over write the last cost center data. \$\endgroup\$ – findwindow Jun 23 '16 at 15:34
  • \$\begingroup\$ dataitems is a variant at beginning of function and you use method exists then at the end create the object?? Also, Len(msg) means false? \$\endgroup\$ – findwindow Jun 23 '16 at 15:35
  • \$\begingroup\$ Sorry about that I did get off topic. Editing now... \$\endgroup\$ – user109261 Jun 23 '16 at 15:38
  • \$\begingroup\$ Just post a new answer. This is a good reference for using classes and dictionary. Please demonstrate your idea of using a boolean property in the class per your first answer in your new answer. That's brilliant but I can't figure out how to implement it. \$\endgroup\$ – findwindow Jun 23 '16 at 15:41
  • \$\begingroup\$ I missed something when I wrote that. The problem that you are going to have trying to implemented the Cost Center not found message, is that each Cost Center may have multiple items associated with it. This would cause multiple messages per Cost Center. I'll do a quick work around. \$\endgroup\$ – user109261 Jun 23 '16 at 15:49
2
\$\begingroup\$

Add this to your DataModel Class

Public Found As Boolean

    If Not locActual Is Nothing Then     'if found
            ........ some code ..........
        Item.Found = True
    Else     'if not found
        Item.Found = False
    End If

EDITED: After we finish adding the data to the Actual's worksheet can pass the data collection to another sub routine.

MissingCallCenterMessage data

    

Sub MissingCallCenterMessage( data as Collection)
    Dim message As String
    Dim item as Variant
    For Each item In failed 'loop through collection to store all failed cost centers into one variable
        If Not item.found then 
            message = message & item.CostCenter & vbNewLine
        End If
    Next

    If Len(message) Then
        MsgBox message, vbInformation, "Cost Centers Not Found"
    End If
End Sub

You would be better off keeping your current strategy than to implement the this.

What you need to do is add the Cost Centers to the failed collection as a key. Keys are unique. The collection will throw an error when you try to add the same key twice. But will can handle that!!


Else 'if not found

    On Error Resume Next
    failed.Add Null, Item.CostCenter
    On Error GoTo 0

End If

This will prevent any duplicate Call Centers from being added to the failed collection.

    Dim message As String
    For Each e In failed 'loop through collection to store all failed cost centers into one variable
        message = message & e & vbNewLine
    Next

    If Len(message) Then
        MsgBox message, vbInformation, "Cost Centers Not Found"
    End If

Boolean logic considers 0 as False and anything <> 0 as true
Len counts the number of characters in a string.
Know that we can do this:

If Len(message) Then

Basically it's short hand for saying if there is a message do something.

\$\endgroup\$
  • \$\begingroup\$ lol I missed something. What exactly is item? It's our class object with 4 properties. So what does item.found really mean? XD \$\endgroup\$ – findwindow Jun 23 '16 at 16:21
  • \$\begingroup\$ It goes back to my idea of having item.costcenter.found but apparently that's not possible XD \$\endgroup\$ – findwindow Jun 23 '16 at 16:27
  • 1
    \$\begingroup\$ It's possible but costcenter would have to be its own class. \$\endgroup\$ – user109261 Jun 23 '16 at 16:31
  • 1
    \$\begingroup\$ The reason for add the found property is for future reference. It would be more useful if your were to do something with the data collection afterward. \$\endgroup\$ – user109261 Jun 23 '16 at 16:33
  • 1
    \$\begingroup\$ Range is not a nested function. It's a Class Object. \$\endgroup\$ – user109261 Jun 23 '16 at 16:52

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.