ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2141|回复: 13

[已解决] 鲜花答谢! 求指点代码修改--按B列条件复制现有工作表生成新工作表

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-9 16:29 | 显示全部楼层 |阅读模式
求老师指点:
     按钮后台对应的代码,会按B列供方名称生成各个供方的工作表,我想不让它自己新创建工作表,而是按照“供方统计”这个工作表(里面设置好了格式)来复制并改名,且将检验台账中HCDEFj列的数据,按顺序复制到对应供方工作表下面的第7行开始的ABCDEF列,不知道怎么改,求老师指点一下!谢谢!
如其他几个工作表示例,感谢!
供方统计模板.zip (160.62 KB, 下载次数: 1)
图示.jpg
Sub 拆分1()
      Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i&
    Set rng = Range("a3:j3")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Range("b1:b" & Range("b65536").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    Set sh = Sheets("供方统计")
    For i = 4 To UBound(arr)
       ' If IsNumeric(arr(i, 1)) Then
            If Not d.Exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 10)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 10))
           ' End If
        End If
    Next
    k = d.Keys
    t = d.Items
   With Sheets
        For i = 0 To d.Count - 1
            With .Add(after:=.Item(.Count))     
                .Name = k(i)
            rng.Copy .Range("A1")
            t(i).Copy .Range("A2")  
    End With
    Next
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("供方统计").Select
    MsgBox "完毕"
    End Sub

TA的精华主题

TA的得分主题

发表于 2019-1-9 17:24 来自手机 | 显示全部楼层
本帖最后由 zmj9151 于 2019-1-9 17:30 编辑

............

TA的精华主题

TA的得分主题

发表于 2019-1-9 17:32 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-1-9 17:51 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-10 11:30 | 显示全部楼层

非常感谢老师的帮助,还有问题需要请教一下:
添加页尾的代码,
Sheet2.[a100:f106].Copy sh.[a65536].End(xlUp) 这段会把最后一行数据覆盖掉,怎么样能往下一行粘贴,不覆盖掉数据。谢谢!
另外,我添加边框的方式是录制宏的,有没有能直接在原代码里简化的呢? 谢谢!
供方统计模板123.zip (52.25 KB, 下载次数: 2)


TA的精华主题

TA的得分主题

发表于 2019-1-10 11:46 | 显示全部楼层
高飞扬 发表于 2019-1-10 11:30
非常感谢老师的帮助,还有问题需要请教一下:
添加页尾的代码,
Sheet2.[a100:f106].Copy sh.[a65536]. ...

拆分代码里加一句加边框的语句:
.Range("a7").Resize(UBound(brr), UBound(brr, 2)).Borders.LineStyle = xlContinuous

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-10 11:50 | 显示全部楼层
高飞扬 发表于 2019-1-10 11:30
非常感谢老师的帮助,还有问题需要请教一下:
添加页尾的代码,
Sheet2.[a100:f106].Copy sh.[a65536]. ...

将拆分代码后面修改一下,边框和表底就都有了:
With ActiveSheet
   .Range("b1") = aa
   .Range("a7").Resize(UBound(brr), UBound(brr, 2)) = brr
    .Range("a7").Resize(UBound(brr), UBound(brr, 2)).Borders.LineStyle = xlContinuous
   .Name = aa
    r = .Cells(.Rows.Count, 1).End(3).Row + 1
    Sheet2.[a100:f106].Copy .Cells(r, 1)
  End With

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-10 11:50 | 显示全部楼层
高飞扬 发表于 2019-1-10 11:30
非常感谢老师的帮助,还有问题需要请教一下:
添加页尾的代码,
Sheet2.[a100:f106].Copy sh.[a65536]. ...

将拆分代码后面修改一下,边框和表底就都有了:
With ActiveSheet
   .Range("b1") = aa
   .Range("a7").Resize(UBound(brr), UBound(brr, 2)) = brr
    .Range("a7").Resize(UBound(brr), UBound(brr, 2)).Borders.LineStyle = xlContinuous
   .Name = aa
    r = .Cells(.Rows.Count, 1).End(3).Row + 1
    Sheet2.[a100:f106].Copy .Cells(r, 1)
  End With

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-10 11:51 | 显示全部楼层
本帖最后由 高飞扬 于 2019-1-10 11:55 编辑
lsc900707 发表于 2019-1-10 11:46
拆分代码里加一句加边框的语句:
.Range("a7").Resize(UBound(brr), UBound(brr, 2)).Borders.LineStyl ...

非常感谢版主的指导, 学习了! 谢谢!

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-10 12:04 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
lsc900707 发表于 2019-1-10 11:50
将拆分代码后面修改一下,边框和表底就都有了:
With ActiveSheet
   .Range("b1") = aa

版主,不好意思,Sheet2.[a100:f106].Copy .Cells(r, 1) 这句加边框,还是不会加……
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 09:29 , Processed in 0.047972 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表