Question

我试图从单独的工作表中提取数据，并在满足条件时将其放入相应的单元格中。我的代码有效，但效率不高。我不知道如何更改For Next循环，以便它只尝试绘制数据，直到最后一个条目。现在我将它设置为比我需要的更多一百个单元格，这样当我向数据表输入新数据时，我就不必经常更新代码（或者至少是那个想法）。这是我的代码：

Sub LRearTest()
   Dim R As Integer
   Dim j As Integer

      For j = 89 To 250
          For R = 1 To 300

           If Worksheets("Input").Cells(j, 22).Value >= Worksheets("1036L").Cells(R, 5).Value And Worksheets("Input").Cells(j, 22).Value <= Worksheets("1036L").Cells(R, 6).Value Then
         Worksheets("Input").Cells(j, 20).Value = Worksheets("1036L").Cells(R, 3).Value

          End If
       Next R
    Next j
End Sub

问题是当我运行此代码时，它需要将近两分钟才能结束。我不确定是不是因为我使用了j和r作为整数或什么。另外，我在一个模块上有十几个，所以我不确定这是否有所贡献。代码就像我说的那样，它的速度太慢了。非常感谢帮助。

我正在检查的重点是Sheet的第五列＆＃34;输入＆＃34;。我要填充的每个列F-U在列V中使用相同的数据。我比较第V列中的数据的表格标记为1030L，1030R，1031L，1031R，1032L，1032R，1033L ，1033R，1034L，1034R，1034LA，1034RA，1035L，1035R，1036L和1036R。被比较的数据在每张表中都在相同的列中。谢谢

Answer 1

这样的事情对你有用：

Sub LRearTest()

    Dim wb As Workbook
    Dim wsInput As Worksheet
    Dim wsData As Worksheet
    Dim aDataParams() As String
    Dim aInput As Variant
    Dim aData As Variant
    Dim InputIndex As Long
    Dim DataIndex As Long
    Dim ParamIndex As Long
    Dim MinCol As Long

    Set wb = ActiveWorkbook
    Set wsInput = wb.Sheets("Input")

    'Adjust the column associations for each sheet as necessary
    ReDim aDataParams(1 To 16, 1 To 3)
    aDataParams(1, 1) = "1030L":    aDataParams(1, 2) = "F"
    aDataParams(2, 1) = "1030R":    aDataParams(2, 2) = "G"
    aDataParams(3, 1) = "1031L":    aDataParams(3, 2) = "H"
    aDataParams(4, 1) = "1031R":    aDataParams(4, 2) = "I"
    aDataParams(5, 1) = "1032L":    aDataParams(5, 2) = "J"
    aDataParams(6, 1) = "1032R":    aDataParams(6, 2) = "K"
    aDataParams(7, 1) = "1033L":    aDataParams(7, 2) = "L"
    aDataParams(8, 1) = "1033R":    aDataParams(8, 2) = "M"
    aDataParams(9, 1) = "1034L":    aDataParams(9, 2) = "N"
    aDataParams(10, 1) = "1034R":   aDataParams(10, 2) = "O"
    aDataParams(11, 1) = "1034LA":  aDataParams(11, 2) = "P"
    aDataParams(12, 1) = "1034RA":  aDataParams(12, 2) = "Q"
    aDataParams(13, 1) = "1035L":   aDataParams(13, 2) = "R"
    aDataParams(14, 1) = "1035R":   aDataParams(14, 2) = "S"
    aDataParams(15, 1) = "1036L":   aDataParams(15, 2) = "T"
    aDataParams(16, 1) = "1036R":   aDataParams(16, 2) = "U"

    'Find minimum column
    MinCol = wsInput.Columns.Count
    For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
        If wsInput.Columns(aDataParams(ParamIndex, 2)).Column < MinCol Then MinCol = wsInput.Columns(aDataParams(ParamIndex, 2)).Column
    Next ParamIndex

    'Based on minimum column, determine column indexes for each sheet/column pair
    For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
        aDataParams(ParamIndex, 3) = wsInput.Columns(aDataParams(ParamIndex, 2)).Column - MinCol + 1
    Next ParamIndex

    With wsInput.Range("F89", wsInput.Cells(wsInput.Rows.Count, "V").End(xlUp))
        If .Row < 89 Then
            MsgBox "No data in sheet [" & wsInput.Name & "]"
            Exit Sub
        End If
        aInput = .Value
    End With

    For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
        'Define data sheet based on current column
        Set wsData = wb.Sheets(aDataParams(ParamIndex, 1))
        aData = wsData.Range("C1", wsData.Cells(wsData.Rows.Count, "F").End(xlUp)).Value

        For InputIndex = LBound(aInput, 1) To UBound(aInput, 1)
            For DataIndex = LBound(aData, 1) To UBound(aData, 1)
                If aInput(InputIndex, UBound(aInput, 2)) >= aData(DataIndex, 3) _
                And aInput(InputIndex, UBound(aInput, 2)) <= aData(DataIndex, 4) Then
                    aInput(InputIndex, aDataParams(ParamIndex, 3)) = aData(DataIndex, 1)
                    Exit For
                End If
            Next DataIndex
        Next InputIndex

        Set wsData = Nothing
        Erase aData
    Next ParamIndex

    wsInput.Range("F89").Resize(UBound(aInput, 1), UBound(aInput, 2)) = aInput

    Set wb = Nothing
    Set wsInput = Nothing
    Set wsData = Nothing
    Erase aInput
    Erase aData
    Erase aDataParams

End Sub

VBA精炼范围

1 个答案: