我需要帮助 - 我的Excel Visual Basic公式不起作用

Question

我的代码无法正常运行。代码仍然需要tweeking来解决一些剩余的问题。它很慢，在下面运行VBA代码后解冻表单需要60秒。

如果有人可以协助此代码，请回复。

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

2013年12月17日：

感谢您的回复。工作簿代码是我收到的帮助。它无法正常工作，并且Stackoverflow响应确认它未正确写入。我不确定为什么最初在另一个帮助网站上提供给我的代码昨天没有使用范围。或者为什么表单需要60秒才能使工作簿完成VBA进程并冻结。

目前的问题如下： 1.估算表（表2）从材料预算（表1）中获取其信息，每个房间只有10行的容差。行应自动填充，直到空格。

1. “估算表”在表单下方列出了几次房间行信息。所以14个房间增加到48个。

2. 传真表（表3和表4）未填充。 Lowes传真和Home Depot传真。

为了帮助您了解工作簿的内容： 材料预算（Sheet1）是一个逐行计算器和产品采购表，它使用A-T列。房间范围如下。有两个额外的范围BUY_Order Approval（列Q），其中需要“Y”响应来实际订购项目，以及Subtotalsrow（列S）。

材料预算（sheet1）共有14个单独的“房间”，分为14个单独的范围，因此不会难以将信息从一个范围区分到另一个范围，其中仅包括产品描述（K列），SKU ＃（列L），成本（列O），数量（列P），零售商（列R）和行余额（列S）。分别为KLOPRS：

范围：

• Supplies_Bathroom1（40行）
• Supplies_Bathroom2（40行）
• Supplies_Bedroom1（33行）
• Supplies_Bedroom2（33行）
• Supplies_Bedroom3（33行）
• Supplies_Bedroom4（33行）
• Supplies_Kitchen（60行）
• Supplies_FrontPorch（33行）
• Supplies_RearPorch
• Supplies_Hallway（25行）
• Supplies_Laundry
• Supplies_Garage
• Supplies_FloridaRoom

如果在Q列中有“Y”响应（购买项目），那么这些行只会复制到材料估算（Sheet2）上，并且在“x”的A列中也会有行选择。 A列只是更改行颜色，以便用户不会忘记完成信息。

如果材料预算（Sheet1）中的Q列（购买项目）中有“Y”，所选行中A列中的“X”，以及列R表示Lowes，则会填充两份传真页或家得宝。两张传真纸中的每一张都隔离了零售商的物品; Lowes传真仅包含从Lowes购买的物品，而Home Depot传真仅包含要从HD购买的物品。传真机上列出的材料按照T栏中指定编号的顺序排列，将所有木材需求放在一起，将所有钉子和螺钉放在一起等，以便商店更容易为订单提取物品。

1. 材料估算（表2）和材料预算（表1）可能总共1到500行，如果项目是完全拆除和更换或只是修理。因此，材料估算和传真应自动循环，直到复制所有合格的行。

任何帮助将不胜感激。

- 为时间而奋斗

Answer 1

我很乐意帮助你，但很抱歉，你的代码非常混乱。我相信如果你自己开始调试它，你将很难做到这一点。无论如何，无论我能理解什么，我都对此发表了评论。

您可以使用结构化方式编写代码，例如

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

现在我看到了几个问题......

1. wb.UsedRange.Rows.Count为什么UsedRange.Rows.Count？并且直到最后一行才循环？您可能希望看到THIS

2. If LCase(wb.Range("Q" & i)) = "y" Then而不是循环使用.Autofilter。例如wb.Range("Q12:Q" & LastRow)).AutoFilter Field:=1, Criteria1:="=y"，然后再次为Col B使用自动过滤。 HERE是有关如何复制已过滤行的示例。

3. 为了让您的代码更快，您可能希望将代码夹在Application.ScreenUpdating = False和Application.ScreenUpdating = True之间

INTERESTING READ