加载中…
个人资料
恩格软件
恩格软件
  • 博客等级:
  • 博客积分:0
  • 博客访问:11,728
  • 关注人气:2
  • 获赠金笔:0支
  • 赠出金笔:0支
  • 荣誉徽章:
相关博文
推荐博文
谁看过这篇博文
加载中…
正文 字体大小:

Excel使用列信息生成新的工作簿

(2021-05-23 15:33:47)
分类: ExcelVBA
Sub 按列分组生成新表()
    On Error GoTo errcode:
    Dim r, arr(), str
    Dim sht, tempsht As Worksheet
    Dim i, j, m As Integer
    Dim d As Object
    
    Set sht = ActiveSheet '指定数据源
    i = sht.UsedRange.Rows.Count '已用单元格行数
    j = sht.UsedRange.Columns.Count '已用单元格列数
    r = Split(ActiveCell.Address, "$")(1)
    
    If MsgBox("请确信是否要对列【" & r & "】进行分解", vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    Set d = CreateObject("scripting.dictionary") '字典对象,字典键值可以去重
    arr = sht.Range(r & "2:" & r & i).Value '给数组赋值
    
    For Each str In arr
        d(str) = str
    Next
    
    Application.ScreenUpdating = False
    For Each str In d.keys
        Debug.Print str
        sht.Range("A1").AutoFilter ActiveCell.Column, str '自动过滤
        Workbooks.Add xlWBATWorksheet '新建工作表
        Set tempsht = ActiveWorkbook.Worksheets("Sheet1") '指定临时工作表
        If sht.FilterMode Then
            sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy tempsht.[A1] '把过滤结果复制到新的临时工作表
        End If
        With tempsht.Columns("A:AJ") '设置临时工作表的列宽和行高自动适应
            .ColumnWidth = 50
            .EntireColumn.AutoFit
            .RowHeight = 25
            .EntireRow.AutoFit
        End With
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & str & ".xlsx" '按客户名称保存临时工作表
        ActiveWorkbook.Close '关闭临时工作表
    Next
    If sht.FilterMode Then sht.Range("A1").AutoFilter '取消过滤
    Application.ScreenUpdating = True
    
    MsgBox "数据表分解成功,请在同目录下查看对应数据", vbInformation
    Exit Sub
    
errcode:
    MsgBox Err.Description, vbInformation
    Exit Sub
End Sub

0

阅读 评论 收藏 转载 喜欢 打印举报/Report
  • 评论加载中,请稍候...
发评论

    发评论

    以上网友发言只代表其个人观点,不代表新浪网的观点或立场。

      

    新浪BLOG意见反馈留言板 电话:4000520066 提示音后按1键(按当地市话标准计费) 欢迎批评指正

    新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 会员注册 | 产品答疑

    新浪公司 版权所有