[已解决]EXCEL表分割另存新文件时图片不能一起移动到新文件中

ykczbf

http://www.excelpx.com/forum.php?mod=attachment&aid=Mjc1NzY2fGQyOGIzMDNmZDY5NTRiYjkzYTYyYzliMmJhNmJiMjRhfDE3MTQwOTQwMjI%3D&request=yes&_f=.rar
请教高手，EXCEL表分割另存的新文件中图片不能一起移动，用了N种方法都无法解决，请高手赐教，不胜感激！详见附档中的原文件，母文件名：PO list.xls,  其它XLS文件为VBA自动另存的多个新文件，以下内容是VBA代码：

Sub 拆分()
    Dim sh As Worksheet, i As Integer, sLocation As String
    'Dim objWorkbook As Object
    Dim iStartName As Long
    Dim Data
    Dim 最大行数, j&, TitleRow&, k
    Dim Headers&, Splitcol&
    Dim dic As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Headers = 1
    Data = Range("a1").CurrentRegion '源数据
    iStartName = Headers + 1
    Splitcol = 4

    Set dic = CreateObject("Scripting.Dictionary")
    For i = iStartName To UBound(Data)
        dic(Data(i, Splitcol)) = dic(Data(i, Splitcol)) + 1
    Next
    最大行数 = Application.Max(dic.items)
    dic.RemoveAll
    For i = iStartName To UBound(Data)
   
        If Not dic.exists(Data(i, Splitcol)) Then
            
            ReDim arr(0 To 最大行数 + Headers - 1, 1 To UBound(Data, 2))
            For j = 1 To UBound(Data, 2)
                For TitleRow = 1 To Headers
                    arr(TitleRow - 1, j) = Data(TitleRow, j)
                Next
                arr(Headers, j) = Data(i, j)
            Next
            dic(Data(i, Splitcol)) = Array(1, arr)
        Else
            'Stop
            arr = dic(Data(i, Splitcol))(1)
            k = dic(Data(i, Splitcol))(0) + 1
            For j = 1 To UBound(Data, 2)
                arr(k + Headers - 1, j) = Data(i, j)
            Next
            dic(Data(i, Splitcol)) = Array(k, arr)
        End If
    Next
    k = dic.keys
    Dim filename$
    For i = 0 To dic.Count - 1
        With Workbooks.Add
            With ActiveSheet
                .Cells.NumberFormatLocal = "@"
                .[A1].Resize(最大行数 + Headers - 1, UBound(Data, 2)) = dic(k(i))(1)
                filename = ThisWorkbook.Path & "\" & .[D2] & "-" & ThisWorkbook.Name
            End With
            .SaveAs filename:=filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
            ', FileFormat:=xlWorkbookNormal
        End With
        
        ActiveWorkbook.Close True
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

最佳答案

月排行榜 / 总排行榜

zjdh

2013-6-1 18:22

Sub 拆分()
    Dim sh As Worksheet, i As Integer, sLocation As String
    Dim iStartName As Long
    Dim Data
    Dim 最大行数, j&, TitleRow&, k
    Dim Headers&, Splitcol&
    Dim dic As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Headers = 1
    Data = Range("a1").CurrentRegion
    iStartName = Headers + 1
    Splitcol = 4
    Set dic = CreateObject("Scripting.Dictionary")
    For i = iStartName To UBound(Data)
        dic(Data(i, Splitcol)) = dic(Data(i, Splitcol)) + 1
    Next
    最大行数 = Application.Max(dic.items)
    dic.RemoveAll
    For i = iStartName To UBound(Data)
        If Not dic.exists(Data(i, Splitcol)) Then
            ReDim arr(0 To 最大行数 + Headers - 1, 1 To UBound(Data, 2) + 1)
            For j = 1 To UBound(Data, 2)
                For TitleRow = 1 To Headers
                    arr(TitleRow - 1, j) = Data(TitleRow, j)
                Next
                arr(Headers, j) = Data(i, j)
            Next
            arr(Headers, j) = i
            dic(Data(i, Splitcol)) = Array(1, arr)
        Else
            arr = dic(Data(i, Splitcol))(1)
            k = dic(Data(i, Splitcol))(0) + 1
            For j = 1 To UBound(Data, 2)
                arr(k + Headers - 1, j) = Data(i, j)
            Next
            arr(k + Headers - 1, j) = i
            dic(Data(i, Splitcol)) = Array(k, arr)
        End If
    Next
    k = dic.keys
    Dim filename$
    For i = 0 To dic.Count - 1
        With Workbooks.Add
            With ActiveSheet
                .CELLS.NumberFormatLocal = "@"
                .Columns("E:E").ColumnWidth = 16.5
                .Rows("2:" & 最大行数 + 1).RowHeight = 60
                BRR = dic(k(i))(1)
                .[A1].Resize(最大行数 + Headers, UBound(Data, 2)) = BRR
                For j = 1 To UBound(BRR)
                    If BRR(j, 9) = "" Then Exit For
                    ThisWorkbook.Sheets(1).CELLS(BRR(j, 9), 5).COPY .CELLS(j + 1, 5)
                Next
                .Columns("A:D").Columns.AutoFit
                .Columns("F:H").Columns.AutoFit
                .Range("A1").CurrentRegion.Borders.LineStyle = 1
                filename = ThisWorkbook.Path & "\" & .[D2] & "-" & ThisWorkbook.Name
            End With
            .SaveAs filename:=filename
        End With
        ActiveWorkbook.Close True
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

跳转到最佳答案楼层

zjdh

数组不能存放图片 ！！

zjdh

Sub 拆分()
    Dim sh As Worksheet, i As Integer, sLocation As String
    Dim iStartName As Long
    Dim Data
    Dim 最大行数, j&, TitleRow&, k
    Dim Headers&, Splitcol&
    Dim dic As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Headers = 1
    Data = Range("a1").CurrentRegion
    iStartName = Headers + 1
    Splitcol = 4
    Set dic = CreateObject("Scripting.Dictionary")
    For i = iStartName To UBound(Data)
        dic(Data(i, Splitcol)) = dic(Data(i, Splitcol)) + 1
    Next
    最大行数 = Application.Max(dic.items)
    dic.RemoveAll
    For i = iStartName To UBound(Data)
        If Not dic.exists(Data(i, Splitcol)) Then
            ReDim arr(0 To 最大行数 + Headers - 1, 1 To UBound(Data, 2) + 1)
            For j = 1 To UBound(Data, 2)
                For TitleRow = 1 To Headers
                    arr(TitleRow - 1, j) = Data(TitleRow, j)
                Next
                arr(Headers, j) = Data(i, j)
            Next
            arr(Headers, j) = i
            dic(Data(i, Splitcol)) = Array(1, arr)
        Else
            arr = dic(Data(i, Splitcol))(1)
            k = dic(Data(i, Splitcol))(0) + 1
            For j = 1 To UBound(Data, 2)
                arr(k + Headers - 1, j) = Data(i, j)
            Next
            arr(k + Headers - 1, j) = i
            dic(Data(i, Splitcol)) = Array(k, arr)
        End If
    Next
    k = dic.keys
    Dim filename$
    For i = 0 To dic.Count - 1
        With Workbooks.Add
            With ActiveSheet
                .CELLS.NumberFormatLocal = "@"
                .Columns("E:E").ColumnWidth = 16.5
                .Rows("2:" & 最大行数 + 1).RowHeight = 60
                BRR = dic(k(i))(1)
                .[A1].Resize(最大行数 + Headers, UBound(Data, 2)) = BRR
                For j = 1 To UBound(BRR)
                    If BRR(j, 9) = "" Then Exit For
                    ThisWorkbook.Sheets(1).CELLS(BRR(j, 9), 5).COPY .CELLS(j + 1, 5)
                Next
                .Columns("A:D").Columns.AutoFit
                .Columns("F:H").Columns.AutoFit
                .Range("A1").CurrentRegion.Borders.LineStyle = 1
                filename = ThisWorkbook.Path & "\" & .[D2] & "-" & ThisWorkbook.Name
            End With
            .SaveAs filename:=filename
        End With
        ActiveWorkbook.Close True
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

ykczbf

zjdh太棒了，运行了一下，郊果很好，正是我想要的，谢谢您!   ^_^

ykczbf

zjdh，您好！我这儿还有一个表格，我的需求是将附档表格内的各个产品图片按供应商归类，图片左边的单元格内的字符串是产品编号，产品编号“-”后面的数字表示的是供应商编号，图片右边单元格内的字符表示数量，要求将产品编号和对应图片及数量3列数据按相同的供应商合并在一起复制这些数据用邮件自动发送到指定的邮箱，供应商编号对应的邮箱地址请见附档的通讯录工作表，发送邮箱可以用我的邮箱，请帮做VBA代码，谢谢！

ykczbf

zjdh 您好！这个发送电子邮件的问题我已在网上找到代码了，但表格拆分还是请您帮忙写一下VBA代码，具体描述是：附档表格中，一列是产品编号，一列是产品图片，一列是订货数量，一页共3排这种格式，但每页的行数是不固定的，行数会因为每天的实际订单变动增加或减少估计最大上限为1000行，产品编号中“-”后面的数字是供应商编号，要求将同一供应商的产品编号，对应产品图片，对应订货数量汇总并以供应商编号为文件名另存为一个新文件，请帮忙写VBA代码，拜谢！

ykczbf

zjdh 发表于 2013-6-1 18:22
Sub 拆分()
    Dim sh As Worksheet, i As Integer, sLocation As String
    Dim iStartName As Long

zjdh 您好！这个发送电子邮件的问题我已在网上找到代码了，但表格拆分还是请您帮忙写一下VBA代码，具体描述是：附档表格中，一列是产品编号，一列是产品图片，一列是订货数量，一页共3排这种格式，但每页的行数是不固定的，行数会因为每天的实际订单变动增加或减少估计最大上限为1000行，产品编号中“-”后面的数字是供应商编号，要求将同一供应商的产品编号，对应产品图片，对应订货数量汇总并以供应商编号为文件名分别另存为新文件，请帮忙写VBA代码，拜谢！ 产品清单1.rar (463 KB, 下载次数: 1) 2013-6-5 11:04 上传 点击文件名下载附件