Question

见下文所示：要解决的问题。

注意：我在底部有Excel电子表格的副本，以便更好地解释以下内容：

我有以下VBA程序，用于查找手动输入的号码：

Sub do_it()

n = [A1]

For Each cell In Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30")
If cell.Value = n And Range(cell.Address).Offset(0, 1) = "1-5" Then
MsgBox "Found a postivive result in " & cell.Address
End If
Next

End Sub

简要说明上述程序（下图中的excel图片）：

1）我在单元格A1中输入一个数字，任意数字。假设我选择了数字4。

2）我有5个列位置和数字4可以找到的范围：A15：A30，C15：C30，E15：E30，G15：G30，I15：I30。每列中都有一个数字4，但只有一列在其右侧的单元格中有一个值。

作为一个例子，当它在单元格E21中找到4并且诸如1-5之类的值（可以是任何数字集合，例如7-5或10-19）时，这是一个肯定的结果。如果它们在F21中没有价值，那么它将是负数，并将继续搜索其他4个，直到它找到正面结果）。到目前为止结束了。

要解决的问题（下面我的Excel电子表格副本：

我的程序的下一部分是将单元格F21的内容（在上例中）复制并粘贴到以下行之一：K1，K2，K3，K4，K5，K6，K7，K8，K9， K10，K11和K12。

在此示例中（来自单元格F21的内容）将被复制并粘贴到单元格L1。我要求程序做的是检查第一个数字（在这种情况下为1到1）并选择适当的行（在这种情况下为1）。程序必须始终选择单元格中两个数字的第一个数字。如果F21中的细胞含量为5-10，则程序将5-10复制到第5行并粘贴到细胞L5中，依此类推。

下一个问题是每次粘贴程序时都将程序复制并粘贴到唯一的单元格位置。因此，从粘贴到单元格L1中的单元格F21中取出1-5的上述示例。下次我在A1框中输入一个新数字，让我们说数字5，程序找到一个正结果（这次是G24），H24的单元格内容是1-7，它复制并粘贴1-7到单元格M1和不要过度纠正单元格L1的内容。粘贴功能将始终在前一个复制和粘贴的右侧继续（在第1行的情况下（从L1开始），它将首先使用L1，然后在整个工作表中使用M1，N1，O1，P1，Q1等。 / p>

（我正在做一个副本和我的电子书的糊状物，因此我会将列号放在首位）

A1                                   J  K    L   M   
4                                   ROW 1   1-5 1-7
                                    ROW 2       
                                    ROW 3       
                                    ROW 4       
                                    ROW 5       
                                    ROW 6       
                                    ROW 7       
                                    ROW 8       
                                    ROW 9       
                                    ROW 10      
                                    ROW 11      
                                    ROW 12      


5       3       4       2       12              
4       9       6       1       13              
9       7       5       10      14              
6       6       5       11      15              
7       7       7       7       16              
5       5       5       5       17              
4       4       4   1-5 4       18              
1       1       1       1       19              
6       6       6       6       20              
1       5       5       5   1-7 4               
10      5       5       5       5               
7       7       7       7       7               
6       6       6       6       6               
5       5       5       5       5               
5       11      22      33      14              
8       18      17      12      15

结束

提前感谢您提供的任何帮助。

拉斯

Answer 1

这应该这样做：

Sub do_it()

    Dim n, sht As Worksheet, cell As Range, num, tmp, rngDest As Range

    Set sht = ActiveSheet

    n = sht.Range("A1")

    For Each cell In sht.Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30").Cells

        tmp = cell.Offset(0, 1).Value

        If cell.Value = n And tmp Like "*#-#*" Then

            'get the first number
            num = CLng(Trim(Split(tmp, "-")(0)))
            Debug.Print "Found a positive result in " & cell.Address

            'find the next empty cell in the appropriate row
            Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1)
            'make sure not to add before col L
            If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12)

            cell.Offset(0, 1).Copy rngDest
            Exit For

        End If
    Next

End Sub

Answer 2

您可以利用Worksheet_Change()事件和Dictionary对象

将此代码放在工作表代码窗格

中

Option Explicit

Dim dict As Object

Sub FillDict()
    Set dict = CreateObject("Scripting.Dictionary") 'set a dictionary object

    Dim cell As Range
    For Each cell In Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30").Offset(, 1).SpecialCells(xlCellTypeConstants) ' loop through relevant range 1-column right offset not empty cells
        dict(cell.Offset(, -1).Value) = cell.Value ' add dictionary itme with current cell one column left offset value as key and current cell value as item
    Next
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$A$1" Then Exit Sub 'do nothing if changed cell is not "A1"

    If dict Is Nothing Then FillDict ' fill dictionary if not already set

    If dict.Exists(Target.Value) Then 'if current cell A1 value is in dictionary keys
        Dim rowIndex As Long
        rowIndex = CLng(Trim(Split(dict(Target.Value), "-")(0))) 'get row index from item associated to found key
        Application.EnableEvents = False 'disable events handling to prevent subsequent sheet cells writing to call this sub again
        cells(rowIndex, WorksheetFunction.Max(cells(rowIndex, Columns.Count).End(xlToLeft).Offset(0, 1).Column, 12)).Value = dict(Target.Value)
        Application.EnableEvents = True 'set events handling back
    End If
End Sub

通过这种方式，您只需将代码读取所有范围单元格一次，并将相关结果存储在字典中，以便每次更改A1单元格内容时进行查询

Answer 3

我想知道我是否可以在您帮助我的程序上寻求您的帮助。我在这里最后有程序的详细信息，但无法正常工作。

我正在尝试让程序将6列范围内的所有数字集向下移动到该列中：E1：E12，B16：B30，E16：E30，H16：H30，K16：K30，N16：N30。仅在E1：E12列中，我需要程序将一组数字（可能在范围内超过一组数字）向下移动到其下方的下一个单元格，并增加该组中的最后一个数字（对计数无限制））。因此，在单元格E1的示例中（8-16）将移动到E2并变为8-17（移动后单元格E1将为空白）。当数字组位于单元格E12中时，它们将移至E1，但仍会增加最后一个数字，并且会不断循环。需要下一个单元的帮助，如果下一个单元已满而不覆盖它，那么程序如何将内容从一个单元向下移动到下一个单元，如果有意义的话，该程序如何将其向下移动。一个例子是单元格E12，如果E1已满但必须移动（首先移动），如何将其移动到E1？

我有以下代码，我认为它可以运行，但似乎无法从您停下的地方继续。

If cell.Value = n And tmp Like "*#-#*" Then
     Cells(irow + 1, icol).Insert Shift:=xlDown
     Cells(irow, icol).Copy Cells(irow + 1, icol)
     Cells(irow, icol).Clear

如何使用VBA

3 个答案: