| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 4161 人关注过本帖
标题:如何实现一下按条件分工作薄
只看楼主 加入收藏
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 
能不能写一下代码,别人写的代码我也是乱了不知道如何调整一下,谢谢。
2022-01-04 17:11
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 

           在实际工作中,有时候需要根据设定的列表对一个工作表中的数据进行拆分,或者拆分为多个工作表,或者拆分为多个工作簿文件,本工具特为这个需求而写,Sub 拆分之四()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Dim ar As Variant, br As Variant
Dim arr()
Set d = CreateObject("scripting.dictionary")
w = InputBox("请输入数据源表中列标题行数", , "1")
If w = "" Then MsgBox "您没有输入数据源表中列标题行数": Exit Sub
x = InputBox("请输入数据源表中拆分依据列的列号", , "8")
If x = "" Then MsgBox "您没有输入数据源表中拆分依据列的列号": Exit Sub
p = MsgBox("拆分为工作表请选择是,拆分为工作簿请选择否", vbYesNoCancel)
If p = vbCancel Then Exit Sub
If p = vbYes Then
    For Each sh In Sheets
        If sh.Name <> "数据源" And sh.Name <> "拆分列表" Then
            sh.Delete
        End If
    Next sh
End If
ar = Sheets("拆分列表").[a1].CurrentRegion
With Sheets("数据源")
    r = .Cells(Rows.Count, 8).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    br = .Range(.Cells(1, 1), .Cells(r, y))
End With
Set Rng = ThisWorkbook.Worksheets("数据源").Rows(1)
For j = 1 To UBound(ar, 2)
    If Trim(br(1, j)) <> "" Then
        n = 0
        ReDim arr(1 To UBound(br), 1 To UBound(br, 2))
        d.RemoveAll
        For i = 2 To UBound(ar)
            If Trim(ar(i, j)) <> "" Then
                d(Trim(ar(i, j))) = ""
            End If
        Next i
        For i = Val(w) + 1 To UBound(br)
            If Trim(br(i, Val(x))) <> "" Then
                mc = Trim(br(i, Val(x)))
                If d.Exists(Trim(mc)) Then
                    n = n + 1
                    For jj = 1 To UBound(br, 2)
                        arr(n, jj) = br(i, jj)
                    Next jj
                End If
            End If
        Next i
        If n <> 0 Then
            If p = vbYes Then
                Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
                With sht
                    .Name = ar(1, j)
                    .[a1].CurrentRegion = Empty
                    Rng.Copy .[a1]
                    .Cells(w + 1, 1).Resize(n, UBound(arr, 2)) = arr
                End With
            ElseIf p = vbNo Then
                Set wb = Workbooks.Add
                With wb.Worksheets(1)
                    .Name = ar(1, j)
                    Rng.Copy .[a1]
                    .Cells(w + 1, 1).Resize(n, UBound(arr, 2)) = arr
                End With
                wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ar(1, j)
                wb.Close
            End If
        End If
    End If
Next j
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
2022-01-04 17:18
独木星空
Rank: 16Rank: 16Rank: 16Rank: 16
来 自:河北省曲阳县
等 级:版主
威 望:71
帖 子:921
专家分:683
注 册:2016-6-29
收藏
得分:14 
回复 5楼 ls_y041
学习学习在说。还是有点蒙。

素数问题的解决是我学习编程永恒的动力。
2022-01-04 17:19
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 
有代码也不行看不明白
2022-01-04 17:49
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("数据集合")
    rs = .Cells(Rows.Count, 26).End(xlUp).Row
    If rs < 3 Then MsgBox "数据集合为空!": End
    ar = .Range("a1:z" & rs)
End With
For Each sh In Sheets
    dc(sh.Name) = ""
Next sh
For i = 3 To UBound(ar)
    If Trim(ar(i, 26)) <> "" Then
        d(Trim(ar(i, 26))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 3 To UBound(ar)
        If Trim(ar(i, 26)) = k Then
            n = n + 1
            For j = 2 To UBound(ar, 2)
                br(n, j - 1) = ar(i, j)
            Next j
        End If
    Next i
    If dc.exists(k) Then
        With Sheets(k)
            r = .Cells(Rows.Count, 25).End(xlUp).Row
            .Range("a3:ab" & r) = Empty
            .[a3].Resize(n, UBound(br, 2)) = br
        End With
    End If
Next k
Application.ScreenUpdating = True
MsgBox "数据拆分完毕!", 64, "提示"
End Sub
2022-01-04 20:12
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 
期待吹版主吧
2022-01-04 20:49
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:451
帖 子:10607
专家分:43182
注 册:2014-5-20
收藏
得分:0 
一开始不就是两表吗?无需贴些不相关的代码。
一个表有数据的,另一个表无数据的。
只见几条箭头路线,看不明白结果是什么。
你就手动算算,将要的结果填到空表里给人看看就好了。人家看不懂会问你,这样交流够直接,不用绕圈子。
2022-01-04 22:40
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 
回复 楼主 ls_y041
我重新调整了一下问题,请版主帮助处理一下,
主表分表.rar (132.46 KB)
2022-01-05 08:45
ls_y041
Rank: 2
等 级:论坛游民
威 望:2
帖 子:175
专家分:66
注 册:2005-9-29
收藏
得分:0 
回复 17楼 吹水佬
主表中的兰色的字段只是为了保存工作表的名称,不用写到下面表中,实际用到的数据只是黄色的部分。我重新上传了附件,请帮助一下
图片附件: 游客没有浏览图片的权限,请 登录注册


[此贴子已经被作者于2022-1-5 08:50编辑过]

2022-01-05 08:47
laowan001
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:66
帖 子:1088
专家分:2682
注 册:2015-12-30
收藏
得分:0 
* 先把总表.xlsx导入到 总表.dbf
local outfile,xoutlist,xfile,xfilename
outfile = sys(2015)
SELECT 工单号,维修类型,领料人,代码 项目,零部件名称 说明,SUM(零部件数量) 数量,销售单价 含税单价,仓库代码 仓库名称 FROM 总表 GROUP BY 工单号,维修类型,领料人,代码,零部件名称,销售单价,仓库代码 HAVING SUM(零部件数量)>0 INTO CURSOR outfile READWRITE

xoutlist = sys(2015)
select distinct 工单号,维修类型,领料人 from &outfile into cursor &xoutlist readwrite
select &xoutlist
scan    && 导出每一个工作表
    xfile = sys(2015)
    select * from &outfile where 工单号=&xoutlist..工单号 and 维修类型=&xoutlist..维修类型 and 领料人=&xoutlist..领料人 ;
        into cursor &xfile readwrite    && 查询一个工作表的数据,根据需要保留或添加必要的字段
    xfilename = alltrim(工单号)+alltrim(维修类型)+alltrim(领料人)
    select &xfile
    copy to &xfilename type xl5
    use in &xfile
    select &xoutlist
end
use in &xoutlist


[此贴子已经被作者于2022-1-5 09:45编辑过]

2022-01-05 09:42
快速回复:如何实现一下按条件分工作薄
数据加载中...
 
   



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

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