I need help - My Excel Visual Basic formula isn't working

Question

My code is not working properly. The code still needs tweeking to resolve some remaining issues. It's slow and it takes 60 seconds to unfreeze the form after running VBA code below.

If anyone can assist with this code please reply.

Sub Crunched(): Dim wb As Worksheet, we As Worksheet, wl As Worksheet, wh As Worksheet
    Dim i As Long, j As Long, k As Long, p As Long, q As Long, r As Long, h As Integer
    Dim Rooms As String, T As Single
    Set wb = Sheets("Materials Budget"): Set we = Sheets("Materials Estimate")
    Set wl = Sheets("Lowes Fax"): Set wl = Sheets("Home Depot Fax"): 'r =      wb.UsedRange.Rows.Count
    For i = 12 To wb.UsedRange.Rows.Count
        If LCase(wb.Range("Q" & i)) = "y" Then
           p = i: Do Until LCase(wb.Range("B" & p)) = "room": p = p - 1: Loop
           If InStr(1, Rooms, wb.Range("B" & p + 1)) = 0 Then
              If h Then
                 T = 0: r = q: Do Until Not IsNumeric(we.Range("I" & r))
                 T = T + we.Range("I" & r): r = r - 1: Loop
                 we.Range("H" & q + 1) = "Total": we.Range("I" & q + 1) = T
              End If
              Rooms = Rooms & " " & wb.Range("B" & p + 1): h = h + 1: q = 10 * h
              wb.Range("B" & p & ":B" & p + 1).Copy we.Range("B" & q)
              wb.Range("K" & p & ":L" & p + 1).Copy we.Range("C" & q)
              wb.Range("O" & p & ":S" & p + 1).Copy we.Range("E" & q): q = q + 1
           End If
           q = q + 1
           wb.Range("B" & i).Copy we.Range("B" & q)
           wb.Range("K" & i & ":L" & i).Copy we.Range("C" & q)
           wb.Range("O" & i & ":S" & i).Copy we.Range("E" & q)
        End If
     Next i
End Sub

Dec 17, 2013:

Thank you for your responses. The workbook code is help that I received. It doesn't work correctly, and Stackoverflow responses confirmed that it isn't written correctly. I wasn't sure why the code originally provided to me on another help site yesterday didn't use ranges. Or why the form takes 60 seconds for the workbook to complete the VBA process and freezes up.

The current problems are the following: 1. The Estimate Sheet (sheet2) gets its information from the Materials Budget (sheet1), and there is only an allowance of 10 rows per room. The rows should autofill until blank spaces.

2. The Estimate Sheet has listed room row information several times further down the sheet. So 14 rooms grew to 48.

3. The Fax sheets (sheets 3 and 4) are not populating. Lowes Fax, and Home Depot Fax.

To help you understand the content of the workbook: The Materials Budget (Sheet1) is a row by row calculator and product sourcing sheet which uses columns A-T. The room ranges are listed below. There are two additional ranges BUY_Order Approval (column Q) where a "Y" response is required to actually order the item, and a Subtotalsrow (column S).

Materials Budget (sheet1) has a total of 14 individual "rooms" grouped in 14 individual ranges so that it doesn't struggle differentiating information from one range to another, which only includes the product description (column K), the SKU# (column L), Cost (column O), Qty (column P), retailer (column R) and row balance (column S). Respectively KLOPRS:

Ranges:

• Supplies_Bathroom1 (40 rows)
• Supplies_Bathroom2 (40 rows)
• Supplies_Bedroom1 (33 rows)
• Supplies_Bedroom2 (33 rows)
• Supplies_Bedroom3 (33 rows)
• Supplies_Bedroom4 (33 rows)
• Supplies_Kitchen (60 rows)
• Supplies_FrontPorch (33 rows)
• Supplies_RearPorch
• Supplies_Hallway (25 rows)
• Supplies_Laundry
• Supplies_Garage
• Supplies_FloridaRoom

Those rows are only copied onto the Materials Estimate (Sheet2) if there is a "Y" response (Buy item) in column Q, and a row selection as well in column A of an "x". Column A just changes the row colors so that the user doesn't forget about completing the information.

The two fax sheets are populated when there is a "Y" in column Q (Buy item) on the Materials Budget (Sheet1), an "X" in column A for selected row, and if the column R says either Lowes or Home Depot. Each of the two fax sheets segregates the retailer items; the Lowes fax only contains items to be purchased from Lowes, and the Home Depot fax only contains items to be purchased from HD. The materials listed on the fax are in order of the assigned number in column T which puts all of the lumber needs together, all of the nails and screws together, etc. so that it's easier for a store to pull items for the order.

1. The Materials Estimate (sheet2) and the Materials Budget (sheet 1) has a potential total of 1 to 500 rows, if the project is a complete demolition and replacement or just a repair. So the Materials Estimate and the Faxes should autoloop until all qualified rows are copied.

Any help would be appreciated.

--Crunched For Time

Answer 1

I would love to assist you but I am sorry, your code is very messy. I am sure if you start debugging it yourself, you will have a hard time doing it. Anyways whatever I could understand, I have commented on that.

You code can be written in a structured way such as

Sub Crunched()
    Dim wb As Worksheet, we As Worksheet, wl As Worksheet, wh As Worksheet
    Dim i As Long, j As Long, k As Long, p As Long, q As Long, r As Long, h As Integer
    Dim Rooms As String, T As Single

    Set wb = Sheets("Materials Budget"): Set we = Sheets("Materials Estimate")
    Set wl = Sheets("Lowes Fax"): Set wl = Sheets("Home Depot Fax")

    For i = 12 To wb.UsedRange.Rows.Count
        If LCase(wb.Range("Q" & i)) = "y" Then
            p = i

            Do Until LCase(wb.Range("B" & p)) = "room": p = p - 1: Loop

            If InStr(1, Rooms, wb.Range("B" & p + 1)) = 0 Then
                If h Then
                    T = 0: r = q
                    Do Until Not IsNumeric(we.Range("I" & r))
                        T = T + we.Range("I" & r): r = r - 1
                    Loop
                    we.Range("H" & q + 1) = "Total": we.Range("I" & q + 1) = T
                End If
                Rooms = Rooms & " " & wb.Range("B" & p + 1): h = h + 1: q = 10 * h
                wb.Range("B" & p & ":B" & p + 1).Copy we.Range("B" & q)
                wb.Range("K" & p & ":L" & p + 1).Copy we.Range("C" & q)
                wb.Range("O" & p & ":S" & p + 1).Copy we.Range("E" & q): q = q + 1
            End If
            q = q + 1
            wb.Range("B" & i).Copy we.Range("B" & q)
            wb.Range("K" & i & ":L" & i).Copy we.Range("C" & q)
            wb.Range("O" & i & ":S" & i).Copy we.Range("E" & q)
        End If
    Next i
End Sub

Now I see couple of problems...

1. wb.UsedRange.Rows.Count Why UsedRange.Rows.Count? and not loop only till the last row? You might want to see THIS

2. If LCase(wb.Range("Q" & i)) = "y" Then Instead of looping use .Autofilter. For example wb.Range("Q12:Q" & LastRow)).AutoFilter Field:=1, Criteria1:="=y" and then use autofilter again for Col B. HERE is an example on how to copy the filtered rows.

3. To make your code fast, You might want to sandwich your code between Application.ScreenUpdating = False and Application.ScreenUpdating = True

INTERESTING READ