求助！指定条件下插入多行。

weiwei9669

问题：
根据作者名字，在“销售数据”中找到相同作者的其它书籍的销售数据，并插入到“原始”清单中。
例如：
作者李虎在“销售数据”中有另外几本书籍的销售数据，在原始表格李虎所在的数据行下，插入“销售数据”中的相关行，如果李虎在原始表格中多次出现，就多次插入。
原始数据

需要根据作者姓名插入的数据

模拟效果（黄色仅用于展示插入效果。）

谢谢各位大神。

3190496160

Sub 插入行数据()
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim cr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("销售数据")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 2 Then MsgBox "销售数据工作表为空！": End
   ar = .Range("a2:k" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 5) <> "" Then
        If Not d.exists(ar(i, 5)) Then Set d(ar(i, 5)) = CreateObject("scripting.dictionary")
        d(ar(i, 5))(i) = ""
    End If
Next i
With Sheets("原始")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 2 Then MsgBox "原始工作表为空！": End
   br = .Range("a1:k" & rs)
   ReDim cr(1 To UBound(ar) + UBound(br), 1 To UBound(br, 2))
    For i = 2 To UBound(br)
        If br(i, 5) <> "" Then
            n = n + 1
            For j = 1 To UBound(br, 2)
                cr(n, j) = br(i, j)
            Next j
            If d.exists(br(i, 5)) Then
                For Each k In d(br(i, 5))
                    n = n + 1
                    For j = 1 To UBound(ar, 2)
                        cr(n, j) = ar(k, j)
                    Next j
                Next k
            End If
        End If
    Next i
    .Range("a2:k" & rs) = Empty
    .[a2].Resize(n, UBound(cr, 2)) = cr
    .[a2].Resize(n, UBound(cr, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160

附件.rar (26.15 KB, 下载次数: 1)

2024-12-10 09:56 上传

点击文件名下载附件