0

I am trying to get sum by month value each time if the two strings on two sheets match

Now I don't see anywhere it is going in an infinite loop but still this program is not responding after a while and I have to eventually close excel via; task manager because even Break command wasn't working.

This is a fairly simply program but I don't know how can I make it shorter than this Please advise.

Option Explicit
Sub SumByMon()

Application.ScreenUpdating = False

Dim wk As Worksheet, wt As Worksheet
Dim Astr As String, Bstr As String
Dim i, j, FinalRow, FinalRowG As Long
Dim sm As Double, Jsum As Double, Fsum As Double, Msum As Double, Asum As Double, Masum As Double, Jusum As Double, Julsum As Double, Ausum As Double, Ssum As Double, Osum As Double, Nsum As Double, Dsum As Double
Dim Dt
Dim LMon As Integer

Set wk = Sheets("BR Mailing List_12-4-15 (3)")
Set wt = Sheets("Total By Month")


FinalRowG = wk.Range("N900000").End(xlUp).Row
FinalRow = wt.Range("A900000").End(xlUp).Row


For i = 2 To FinalRow

    Jsum = 0
    Fsum = 0
    Msum = 0
    Asum = 0
    Masum = 0
    Jusum = 0
    Julsum = 0
    Ausum = 0
    Ssum = 0
    Osum = 0
    Nsum = 0
    Dsum = 0

    Astr = Trim(wt.Range("A" & i))


    For j = 2 To FinalRowG

    Bstr = Trim(wk.Range("N" & j))

        If Astr = Bstr Then

            Dt = wk.Range("T" & j).Value
            LMon = Month(Dt)

               Select Case LMon
                Case 1
                    sm = wk.Range("S" & j).Value
                    Jsum = Jsum + sm
                Case 2
                    sm = wk.Range("S" & j).Value
                    Fsum = Fsum + sm
                Case 3
                    sm = wk.Range("S" & j).Value
                    Msum = Msum + sm
                Case 4
                    sm = wk.Range("S" & j).Value
                    Asum = Asum + sm
                Case 5
                    sm = wk.Range("S" & j).Value
                    Masum = Masum + sm
                Case 6
                    sm = wk.Range("S" & j).Value
                    Jusum = Jusum + sm
                Case 7
                    sm = wk.Range("S" & j).Value
                    Julsum = Julsum + sm
                Case 8
                    sm = wk.Range("S" & j).Value
                    Ausum = Ausum + sm
                Case 9
                    sm = wk.Range("S" & j).Value
                    Ssum = Ssum + sm
                Case 10
                    sm = wk.Range("S" & j).Value
                    Osum = Osum + sm
                Case 11
                    sm = wk.Range("S" & j).Value
                    Nsum = Nsum + sm
                Case 12
                    sm = wk.Range("S" & j).Value
                    Dsum = Dsum + sm
                Case Else
                Debug.Print LMon

            End Select

            Else: End If

    Next j

    wt.Range("B" & i) = Jsum
    wt.Range("C" & i) = Fsum
    wt.Range("D" & i) = Msum
    wt.Range("E" & i) = Asum
    wt.Range("F" & i) = Masum
    wt.Range("G" & i) = Jusum
    wt.Range("H" & i) = Julsum
    wt.Range("I" & i) = Ausum
    wt.Range("J" & i) = Ssum
    wt.Range("K" & i) = Osum
    wt.Range("L" & i) = Nsum
    wt.Range("M" & i) = Dsum

Next i

wt.Select
Range("A1").Select
Application.ScreenUpdating = True

End Sub

Thanks for all your effort but even by using array method it is getting in Non-Responding state if you want to have a look at the File Here it is.

7
  • try adding little debug tests, like print statements within each for loop, and see how far your program gets Commented Dec 7, 2015 at 21:33
  • @NoamHacker Thank you for the tip. But if my program stops responding how will Debug help me. Even Break command doesn't works. Commented Dec 7, 2015 at 21:41
  • add a print statement to parts of your program to see if your program prints those statements before it stops responding. this may help you isolate the where the problem is Commented Dec 7, 2015 at 21:45
  • You need to determin what each variable is, for example Dim wk, wt As Worksheet should be Dim wk as worksheet, wt As Worksheet Keeping it on the same line does not make them both worksheets. wk would become a variable. All your Dim's need to be fixed. Commented Dec 7, 2015 at 21:49
  • @Davesexcel That can be a good way to write the program I will do it, but is it necessary ? I have used this way of declarations before and it worked before. Commented Dec 7, 2015 at 21:52

2 Answers 2

2

There are a number of reasons why this code could have problems:

  1. This line could fail if it's an old or compatibility mode version of Excel : wk.Range("N900000").End(xlUp).Row.
  2. You are writing every cell individually which is very time-consuming. If Sheet3 has a lot of rows in it then your code could appear locked because it's taking so long to write
  3. Your declarations have ceded control of types because all the 'untyped' declarations are Variants. This makes debugging very difficult. In your comment you ask "is it necessary?". Answer: not critical, but it will increase your debugging task by an order of magnitude and the code might work in ways you don't expect. In truth, a practical answer is "yes, it's very necessary".
  4. There are no checks of the cell values and types. If cells are empty or not dates, your code will still run, And if all your variables are Variants, your code will aggregate incorrectly when you run Month(dt).
  5. Using the .Text property can cause problems. If for example the date column is too narrow and you have #### in the cell, then that will be the .Text value (again, out of your control if your variable is an 'undeclared' Variant. Better would be Cstr(cell.Value) or Cstr(cell.Value2).
  6. Your code is very inefficient because it loops through the same data in Sheet1 over and over again. Far better would be to load that just once into a collection whose key is the string value that you are testing. I haven't done that in the sample below as I'm a bit short of time but you should look into doing it. If Sheet1 has a lot of rows then your code really will be slow.

The other point is that it's far quicker to write an array to the Worksheet rather than one cell at a time. In your case, the month aggregations are ideally suited to an array. So you could optimise and shorten your code by using one. The code below deals with the points above and uses an array as an example for you.

You also seem a little unclear about the Debug.Print suggestion made by Noam Hacker. It's a good suggestion so I've given you a couple of examples of it in this code:

Public Sub SumByMonWithArray()
    Dim startRowA As Long, startRowB As Long
    Dim finalRowA As Long, finalRowB As Long
    Dim strA As String, strB As String
    Dim m() As Variant
    Dim dt As Variant
    Dim r As Long, c As Long
    Dim i As Long, j As Long

    'Define the start and end rows of each sheet
    startRowA = 2
    startRowB = 2
    finalRowA = Sheet3.Cells(Sheet3.Rows.Count, "A").End(xlUp).Row
    finalRowB = Sheet1.Cells(Sheet1.Rows.Count, "N").End(xlUp).Row

    'Dimension your array
    r = finalRowA - startRowA + 1
    If r < 1 Then Exit Sub 'exit if there's no data
    ReDim m(1 To r, 1 To 12)

    For i = startRowA To finalRowA

        Debug.Print "In loop i=" & CStr(i) 'shows progress (delete after testing)
        strA = Trim(CStr(Sheet3.Cells(i, "A").Value2))

        'If test value isn't blank run the comparison
        If strA <> "" Then

            r = i - startRowA + 1

            For j = startRowB To finalRowB

                Debug.Print "In subloop i=" & CStr(i) & ", j=" & CStr(j) 'shows progress (delete after testing)

                strB = Trim(CStr(Sheet1.Cells(j, "N").Value2))

                'If there's a match aggregate the month array
                If strB <> "" And strA = strB Then
                    'Populate a Variant with cell value and check it's a date
                    dt = Sheet1.Cells(j, "T").Value
                    If IsDate(dt) Then
                        c = Month(dt) 'Gets the column index of the array
                        m(r, c) = m(r, c) + CDbl(Sheet1.Cells(j, "S").Value2)
                    End If
                End If

            Next

        End If

    Next

    'Write the aggregate array to Sheet 3
    With Sheet3
        .Cells(startRowA, "B").Resize(UBound(m, 1), UBound(m, 2)).Value = m
        .Activate
        .Range("A1").Select
    End With
    Application.ScreenUpdating = True

End Sub
Sign up to request clarification or add additional context in comments.

4 Comments

Thanks for all your effort but even by this method it is getting in Non-Responding state if you want to have a look at the File Here it is.
@RohanK, suggest you check the immediate window to see if the debug.print code is showing the loop has even started. If it hasn't then there's probably something up with the workbook/sheet itself - protected, corrupt, etc. Try copying and pasting sheets to a new workbook and have another go.
Did that same results :\
I think the issue is its size. For a reason I don't understand, if you activate a different window Excel seems to lose priority and the VBA stops running. My money is that you have clicked another window or your computer went to sleep while the macro was running. DoEvents seems to prevent this - again, I don't know why - so try sticking it in your j loop. Try it for several thousand iterations to see if that solves it. In any event, the inefficiency of the code for such a huge number of iterations means you'll probably need to run this overnight to go to completion.
1

Consider this mock-up data in Sheet1:
MockUpData

First add a column to the right of column T (Date of Sales?) with formula =MONTH(T2) for cell U2.

Add/Change the Monthly label to Integer (B1:M1 in sample).

Then create dynamic named ranges:

  • SalesItemCol with formula =OFFSET(Sheet1!$N$1,1,0,COUNTA(Sheet1!$N:$N)-1,1)
  • SalesQtyCol with formula =OFFSET(Sheet1!$N$1,1,5,COUNTA(Sheet1!$N:$N)-1,1)
  • SalesMonthCol with formula =OFFSET(Sheet1!$N$1,1,7,COUNTA(Sheet1!$N:$N)-1,1)

Finally on B2, use formula =SUMIFS(SalesQtyCol,SalesItemCol,$A2,SalesMonthCol,B$1) then auto fill the rest.

Alternatively you can create macro to do the above...

Comments

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.