Question

在范围内循环时，我碰到了一点墙。我完成的工作是创建一个表，当在表中选择一个数量时，该表中的范围将被传输到下一个空行上的另一个数组。我想做的是加快处理速度，如果我想第二次将相同的信息添加到msgbox的下一行，询问是或否，然后遍历。

下面是我的代码，我尝试了几种方法，但均未成功

Sub Add()

Dim foundCell As Range
Dim mysearch As Integer
Dim iRow As Long, Last As Long
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws2 = Worksheets("Output")

iRow = ws2.Cells(ws2.Rows.Count, "V").End(xlUp).Row + 1
Last = ws2.Cells(ws2.Rows.Count, "N").End(xlUp).Row

    mysearch = ws2.Range("N10").Value


If ws2.Range("N10").Value = 0 Then
    MsgBox "No Product Selected"
    Exit Sub
    Else
    Do
    Set foundCell = ws2.Range("N12:N" & Last).Find(What:=mysearch, Lookat:=xlWhole)
        If Not foundCell Is Nothing Then
            ws2.Cells(iRow, 22).Value = foundCell.Offset(0, -3).Value
            ws2.Cells(iRow, 23).Value = foundCell.Offset(0, -4).Value
            ws2.Cells(iRow, 24).Value = foundCell.Offset(0, -2).Value
            ws2.Cells(iRow, 25).Value = foundCell.Offset(0, -1).Value
            ws2.Cells(iRow, 26).Value = foundCell.Offset(0, 1).Value
            ws2.Cells(iRow, 27).Value = foundCell.Value
            ws2.Cells(iRow, 28).Value = foundCell.Offset(0, 2).Value
        answer = MsgBox("Would you like to add this product to the next line?", vbYesNo + vbQuestion, "MORE PRODUCTS?")
            If answer = vbYes Then
                Loop
                Else
                'Exit Sub
            End If
        End If
End If

Sheets("Output").Range("N12:N35").ClearContents

End Sub

Answer 1

我不确定我是否正确，但这就是我的理解

Option Explicit

Sub Add()

    Dim foundCell As Range
    Dim mysearch As Integer
    Dim iRow As Long, Last As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim answer As Boolean

    Set ws2 = Worksheets("Output")

    iRow = ws2.Cells(ws2.Rows.Count, "V").End(xlUp).Row + 1
    Last = ws2.Cells(ws2.Rows.Count, "N").End(xlUp).Row

        mysearch = ws2.Range("N10").Value

    If ws2.Range("N10").Value = 0 Then
        MsgBox "No Product Selected"
        Exit Sub
    Else
        Set foundCell = ws2.Range("N12:N" & Last).Find(What:=mysearch, Lookat:=xlWhole)
        If Not foundCell Is Nothing Then
            Do 'this way it'll copy at least once
                answer = CopyCells(foundCell, ws2, iRow)
            Loop While answer 'copy till user choose NO
        End If
    End If

    Sheets("Output").Range("N12:N35").ClearContents
End Sub

Function CopyCells(SrcRange As Range, DestWs As Worksheet, iRow As Long) As Boolean

    Dim UserChoice As Long

    DestWs.Cells(iRow, 22).Value = SrcRange.Offset(0, -3).Value
    DestWs.Cells(iRow, 23).Value = SrcRange.Offset(0, -4).Value
    DestWs.Cells(iRow, 24).Value = SrcRange.Offset(0, -2).Value
    DestWs.Cells(iRow, 25).Value = SrcRange.Offset(0, -1).Value
    DestWs.Cells(iRow, 26).Value = SrcRange.Offset(0, 1).Value
    DestWs.Cells(iRow, 27).Value = SrcRange.Value
    DestWs.Cells(iRow, 28).Value = SrcRange.Offset(0, 2).Value

    UserChoice = MsgBox("Would you like to add this product to the next line?", vbYesNo + vbQuestion, "MORE PRODUCTS?")

    If UserChoice = 6 Then
        CopyCells = True
        iRow = iRow + 1
    Else
        CopyCells = False
    End If

End Function

可能需要一些调整。也许您可以发布您的输入和所需的输出？

使用msgbox遍历范围

1 个答案: