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

对于解决这个问题我有一些想法，但是我不知道如何在VBA中一起处理这两个单独的函数的链接。 我希望代码能够find在一个范围内不是空白的单元格，并插入一个新的行与其各自的数据。 例：

No abcd q1 q2 q3 q4 q5 1 XXXX poor rubbish 2 YYYY excellent great 

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

最终的结果应该是这样的：

  No abcd q1 q2 q3 q4 q5 1 XXXX poor 1 XXXX rubbish 2 YYYY excellent 2 YYYY 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