Question

为了记录，我是一个未经训练，录制的宏观VBA用户。我尝试在这里和那里拾取零碎的东西，但我仍然是一个完整的菜鸟。请指出我正确的方向！

在每一行上，部件号（E列）应与源和地址（列G和H）和描述（第I列）相关联。我说“应该”，但实际上，而不是每个部件号的一个源/地址组合，在许多文件中，某些行上有多达十五种不同的源/地址组合，并且源/地址组合列在相邻的列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

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

这有意义吗？在我的脑海中，我听到VBA函数我从来没有像循环，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

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

1 个答案: