在Excel VBA中，基于列数据创建新行

Question

恕我直言，我是一名未经培训、仅录制宏的VBA用户。我试着到处捡零碎的东西，但我还是个十足的傻瓜。请给我指出正确的方向！

在每一行上，零件编号（E列）应与源和地址（G和H列）以及描述（I列）相关联。我说“应该”，但实际上，不是每个零件编号一个源/地址组合，在许多文件中，在某些行上有多达15个不同的源/地址组合，源/地址组合列在相邻的列J/K、L/M、N/O等中，这将描述列推向右侧。

我需要找到一种VB方法，在有源/地址组合的情况下重复行的次数，并除去除一个组合之外的所有行。下面是一个示例：

   A   B   C   D  Part#  F  Source1  Address1  Source2  Address2   Description
1  x   x   x   x  Part1  x  (S1)     (A1)                          Nut
2  x   x   x   x  Part2  x  (S1)     (A1)      (S2)     (A2)       Bolt

第2行有两个源/地址组合，每行只需要复制一个组合，如下所示：

   A   B   C   D  Part#  F  Source   Address  Description
1  x   x   x   x  Part1  x  (S1)     (A1)     Nut
2  x   x   x   x  Part2  x  (S1)     (A1)     Bolt
3  x   x   x   x  Part2  x  (S2)     (A2)     Bolt

在另一个文件中，我可能在任何给定行上有多达15个不同的源/地址组合，然后需要将其复制15次。

这有意义吗？在我的脑海中，我听到了我从未使用过的VBA函数，如loop、do while、do until等。但我不知道足够的语法来开始实现任何东西。劝告

Answer 1

Sub Test()

Dim rw As Range, rwDest As Range, cellSrc As Range
Dim colDesc As Long, f As Range

    colDesc = 0
    'see if we can find the "description" column header
    Set f = Sheet1.Rows(1).Find(what:="Description", LookIn:=xlValues, lookat:=xlWhole)
    If Not f Is Nothing Then colDesc = f.Column

    Set rw = Sheet1.Rows(2)
    Do While Len(rw.Cells(, "E").Value) > 0
        Set cellSrc = rw.Cells(, "G")
        Do While Len(cellSrc.Value) > 0 And _
                 UCase(Sheet1.Rows(1).Cells(cellSrc.Column).Value) Like "*SOURCE*"
            Set rwDest = Sheet2.Cells(Rows.Count, "E").End(xlUp). _
                         Offset(1, 0).EntireRow
            rw.Cells(1).Resize(1, 6).Copy rwDest.Cells(1)
            cellSrc.Resize(1, 2).Copy rwDest.Cells(7)
            If colDesc > 0 Then rw.Cells(colDesc).Copy rwDest.Cells(9)

            Set cellSrc = cellSrc.Offset(0, 2)
        Loop
        Set rw = rw.Offset(1, 0)
    Loop

End Sub