16，汇总至多工作簿（Move/SaveAs）

'16，汇总至多工作簿（Move/SaveAs）

'http://club./thread-598830-1-1.html

Sub fb()

    Dim i&, Myr&, Myc%, Arr, col%, bt, n&, pa$, nm$

    Dim Sht1 As Worksheet, Sht As Worksheet

    Application.ScreenUpdating = False

    pa = ThisWorkbook.PATH

    Set Sht1 = ActiveSheet

    Myr = [a65536].End(xlUp).Row

    Myc = [iv2].End(xlToLeft).Column

    Arr = Range("a2", Cells(Myr, Myc))

    bt = Array("品牌", "类", "零", "厂址", "编号")

    For col = 11 To UBound(Arr, 2)

        Sheets.Add after:=Sheets(Sheets.Count)

        n = 2

        Set Sht = ActiveSheet

        [a1] = Arr(1, col) & "-" & Sht1.[a1].Value

        [a2].Resize(1, 5) = bt

        Cells(n, 6) = Arr(1, col)

        For i = 2 To UBound(Arr)

            If Arr(i, col) <> "" Then n = n + 1

                Cells(n, 1) = Arr(i, 1)

                Cells(n, 2) = Arr(i, 7)

                Cells(n, 3) = Arr(i, 8)

                Cells(n, 4) = Arr(i, 9)

                Cells(n, 5) = Arr(i, 10)

                Cells(n, 6) = Arr(i, col)

            End If

        Next

        Range("a2:f" & n).Borders.LineStyle = 1

        Cells.Select

        With Selection.Font

            .Name = "宋体"

            .Bold = True

            .Size = 16

        End With

        With Selection

            .HorizontalAlignment = xlCenter

        End With

        Range("A1:F1").Merge

        nm = pa & "\" & Arr(1, col) & Sht1.[a1].Value & ".xls"

        Sht.Move

        ActiveWorkbook.SaveAs FileName:=nm

        ActiveWorkbook.Close

    Next

    Application.ScreenUpdating = True

End Sub