Question

我有一些关于解决这个问题的想法，但它是两个独立函数的链接，我不知道如何在VBA中一起处理。我希望代码能够找到一个范围内不为空的单元格，并插入一个带有相应数据的新行。例如：

    No  a   b   c   d   q1     q2       q3       q4     q5
    1   X   X   X   X          poor     rubbish     
    2   Y   Y   Y   Y          excellent         great

数据可以出现在q1和q5之间的任何地方，我希望VBA将q1-q5中的每个响应与单独的行分开。因此我假设我需要一个循环函数来查看q1和q5之间以查明单元格是否为空白，并且从此我希望新行将每个响应与它们自己的行分开，但我不是确定如何告诉VBA在q2下留下“穷人”并寻找下一个非空白并取出非空白并插入一个新行（所以''垃圾'应该被带到新行，但从它的原始行中删除，以便“穷人”可以拥有自己独立的路线。

最终结果应如下所示：

   No   a   b   c   d   q1     q2       q3       q4     q5
    1   X   X   X   X          poor             
    1   X   X   X   X                   rubbish     
    2   Y   Y   Y   Y          excellent        
    2   Y   Y   Y   Y                            great

Answer 1

希望这个有点帮助

Sub Sorter()
    Dim xrow As Integer
    Dim xcolumn As Integer
    Dim firstword As Boolean

    xrow = 2
    firstword = True

    Do
        xcolumn = 6
        Do
            If Cells(xrow, xcolumn).Value <> "" Then 'if not empty then
                If firstword = True Then 'checks if it is first time word is present in cell
                    firstword = False 'if true then set it to false for next one
                Else
                    Cells(xrow + 1, xcolumn).EntireRow.Insert 'if its not the first occasion then insert row beneath
                    Cells(xrow + 1, xcolumn).Value = Cells(xrow, xcolumn).Value 'rewrite the value
                    Cells(xrow, xcolumn).ClearContents 'and delete the original
                    Range(Cells(xrow + 1, 1), Cells(xrow + 1, 5)).Value = Range(Cells(xrow, 1), Cells(xrow, 5)).Value 'copy the head of the original
                End If
            End If
            xcolumn = xcolumn + 1 'advance one column further
        Loop Until xcolumn = 11 'specified by user, probably last question which is 10th column for me
        xrow = xrow + 1 'advance one row further
        firstword = True
    Loop Until Cells(xrow, 1) = "" 'will loop until there is no remaining head in column 1 also can be specified as "until xrow=maxrow
    End Sub

在范围内查找文本并插入新行

1 个答案: