| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 3412 人关注过本帖
标题:求大神帮忙···关于表格的分拆
只看楼主 加入收藏
yanqihua
Rank: 1
等 级:新手上路
帖 子:9
专家分:0
注 册:2018-10-25
结帖率:66.67%
收藏
已结贴  问题点数:20 回复次数:14 
求大神帮忙···关于表格的分拆
小弟向各位大哥请教:
公司有好多业务员(约100人),各业务员管理着不同的客户和供应商。相互之间最好不要看到对方客户和供应商的信息。
我们经常需要从软件里面导出一个表,里面有所有业务员的业务数据,我们经常要提醒业务员,哪些单位的采购发票未回来、哪些单位付钱了没交货,哪些单位还欠钱,所以需要把导出来的表,按业务员一个一个的选出来,表中其他数据整行留着,另存为一个表,表的文件名叫业务员姓名就可以了,再分别发给对应的人,这工作难度不高,但累死了,手都要点残了,希望大哥们帮忙设计一个VBA程序 ,助我脱苦海,谢谢~~~附件为信息,请参考。
190327入库未开票报表 - 副本.rar (11.59 KB)
搜索更多相关主题的帖子: 表格 业务 导出 数据 单位 
2019-03-28 14:24
xyxcc177
Rank: 9Rank: 9Rank: 9
等 级:贵宾
威 望:26
帖 子:197
专家分:1249
注 册:2017-7-8
收藏
得分:0 
没有示例
2019-03-30 13:34
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:10 
打开excel文件,按组合键Alt + F11 进入VBA编辑界面,
在项目侧栏右键,点击 导入文件:
图片附件: 游客没有浏览图片的权限,请 登录注册
2019-04-01 14:05
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:10 
以下代码,先另存为 “拆分sheet.bas”文件,
程序代码:
Attribute VB_Name = "按某列把Sheet拆分为多个文件"
'按照某列的选项分成多个Excel表格,总提示报错,请帮忙看一下,谢谢
'说明,A、必须保证有一个Sheet名为“数据源”!其余无问题,可以运行
'B、在运行的过程中,会删除 除“数据源”之外的所有Sheet
'A、B 由5hawn根据实际情况,作了修改。
'此程序的特点:在拆分的过程中,会保留原来的格式(字体、颜色等)
Sub CutSheetByColumn()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As String, shtName As String
    Dim columnNum As Integer, shtCount As Integer
    myRange = Application.InputBox(prompt:="请选择标题行:", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="请选择拆分的表头,必须是第一行,且为一个单元格,如:“姓名”", Type:=8)
    title = titleRange.Value
    shtName = titleRange.Areas.Parent.Worksheet.Name
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
'    For i = Sheets.Count To 1 Step -1
'        If Sheets(i).Name <> "数据源" Then
'            Sheets(i).Delete
'        End If
'    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets(shtName).UsedRange.Rows.Count
    Arr = Worksheets(shtName).Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k)
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        Sql = "select * from [" & shtName & "$] where " & title & " = '" & k(i) & "'"
        Dim Nowbook As Workbook
        Set Nowbook = Workbooks.Add
        With Nowbook
            With .Sheets(1)
                .Name = k(i)
                For num = 1 To UBound(myArray)
                    .Cells(1, num) = myArray(num, 1)
                Next num
                .Range("A2").CopyFromRecordset conn.Execute(Sql)
            End With
        End With
        ThisWorkbook.Activate
        Sheets(shtName).Activate
        Sheets(shtName).Cells.Select
        Selection.Copy
        Workbooks(Nowbook.Name).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Nowbook.SaveAs ThisWorkbook.Path & "\" & k(i)
        Nowbook.Close True
        Set Nowbook = Nothing
        shtCount = shtCount + 1
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "以[" & title & "]列拆分Sheet[" & shtName & "],完成。共拆为[" & shtCount & "]个文件。", vbOKOnly, "提示:"
End Sub

2019-04-01 14:06
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:0 
然后选中这个bas文件,导入,导入后,界面如图:
图片附件: 游客没有浏览图片的权限,请 登录注册
2019-04-01 14:07
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:0 
点击上面的三角按钮,运行这个宏代码(请自行解决宏代码的安全性规则)
运行后,会首先询问以哪一行作为标题行,一般来说,标题行总是第一行,当然,有时也有例外:
图片附件: 游客没有浏览图片的权限,请 登录注册
2019-04-01 14:09
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:0 
接着,是指定以哪一列作为关键字拆分,这里点击 [C1]格:
图片附件: 游客没有浏览图片的权限,请 登录注册
2019-04-01 14:10
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:0 
然后程序会自动进行拆分,等等约 1分钟(视用户数据量而定),因这个操作涉及到I/O,所以肯定会慢一些,直到出现:
图片附件: 游客没有浏览图片的权限,请 登录注册

2019-04-01 14:12
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:0 
此外,拆分好的文件是存在与母文件相同的路径下,所以,一般不建议母文件直接放在桌面上,否则程序运行完毕,桌面上会多出一堆文件,所以在运行这个之前,先把母文件放在一个专门的文件夹中,是一个好主意。拆分后的效果:
图片附件: 游客没有浏览图片的权限,请 登录注册

2019-04-01 14:13
厨师王德榜
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:199
帖 子:987
专家分:4946
注 册:2013-2-16
收藏
得分:0 
最后提醒一个注意事项,如果欲拆分的列不是文本型的,而是数值型,那么本程序不适用。
此问题常见于用户根据 某个代码(客户代码,身份证、电话号码)等来拆分,而用户的表中,这一列实际是数值,这样的话 ,本程序会出现错误。
2019-04-01 14:16
快速回复:求大神帮忙···关于表格的分拆
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.017120 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved