帮忙写一个宏（把一个工作薄的内容复印到另一个工作薄）

fannie_2007

请求帮忙，文件中有两个工作薄，一个是报销明细，一个是报销流水，就是要求写一个宏，每次运行，都可以把报销流水红色单元格的内容按顺序复制到报销流水相应的单元格内。意思是每次写的申购单，把重要的内容复制到报销流水，方便日后查阅。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

fannie_2007

可以了,感谢.你真棒

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim br()
Dim rn As Range, rng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 4 Then MsgBox "汇总表为空！": End
    ar = .Range("a2:l" & r - 3)
    Set rn = .Range("a" & r - 2 & ":i" & r)
    Set rng = .Range("a1:i3")
End With
For i = 3 To UBound(ar)
    If ar(i, 10) = "" Then ar(i, 10) = ar(i - 1, 10)
    If ar(i, 12) = "" Then ar(i, 12) = ar(i - 1, 12)
    s = ar(i, 12)
    If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
    d(s)(i) = ar(i, 10)
Next i
Application.SheetsInNewWorkbook = 1
For Each k In d.keys
    n = 0: hj = 0
    ReDim br(1 To d(k).Count, 1 To 9)
    For Each kk In d(k).keys
        dp = ar(kk, 10)
        n = n + 1
        For j = 1 To 9
            br(n, j) = ar(kk, j)
        Next j
    Next kk
    Set wb = Workbooks.Add
    With wb.Worksheets(1)
        .Name = k
        rng.Copy .[a1]
        .[a2] = "店铺名：" & dp & "                            金额：元"
        .[a4].Resize(n, UBound(br, 2)) = br
        .[a4].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
        rn.Copy .Cells(n + 4, 1)
        .Cells(n + 5, 8).FormulaR1C1 = "=SUM(R[-" & n + 1 & "]C:R[-1]C)"
    End With
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub