Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3924|回复: 17

[已解决]再问老师,请问这个如何修改?

[复制链接]
发表于 2017-2-18 21:32 | 显示全部楼层 |阅读模式
本帖最后由 love_liwu 于 2017-2-20 23:31 编辑

上一篇:[已解决]麻烦grf1973 老师帮忙修改红色标识代码,谢谢!
http://www.excelpx.com/thread-427830-1-1.html
(出处: Excel精英培训网)


shjarthur老师帮忙解答了,在此表示感谢shjarthur!同时也感谢grf1973 老师。现在我还有这样的疑问 疑问1.zip (21.61 KB, 下载次数: 5)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-2-19 20:32 | 显示全部楼层
真是神一样的提问啊怪不得 这么久没人回答你
这个描述 鬼才看得懂
回复

使用道具 举报

 楼主| 发表于 2017-2-19 21:29 | 显示全部楼层
lygkkk 发表于 2017-2-19 20:32
真是神一样的提问啊怪不得 这么久没人回答你
这个描述 鬼才看得懂

您好,老师,感谢您指出,我已重新修改,请您看看,谢谢!

回复

使用道具 举报

发表于 2017-2-19 21:36 | 显示全部楼层
唉~~你是想在 顾客信息登记表 录入公司代码小类 其他的信息自动填充吧
回复

使用道具 举报

 楼主| 发表于 2017-2-19 21:42 | 显示全部楼层
lygkkk 发表于 2017-2-19 21:36
唉~~你是想在 顾客信息登记表 录入公司代码小类 其他的信息自动填充吧

不是,我是想根据《客户信息表》的内容和《顾客信息》模板,批量生成工作簿。
回复

使用道具 举报

发表于 2017-2-19 21:48 | 显示全部楼层
那就是说以 公司小类 这个条件分喽
按照我的理解 第一张截图 就分4个工作簿
GD001华南地区 1张
GD002             1张
BJ003华北地区  1张
GD010             1张
是吧
回复

使用道具 举报

 楼主| 发表于 2017-2-19 22:01 | 显示全部楼层
本帖最后由 love_liwu 于 2017-2-19 22:55 编辑
lygkkk 发表于 2017-2-19 21:48
那就是说以 公司小类 这个条件分喽
按照我的理解 第一张截图 就分4个工作簿
GD001华南地区 1张

是的,按效果图示意!
回复

使用道具 举报

发表于 2017-2-20 18:24 | 显示全部楼层
  1. Private Sub CommandButton2_Click()
  2.     Dim arr
  3.     Dim brr
  4.     Dim dic
  5.     Dim My_path As String
  6.    
  7.     Dim i As Long
  8.     Dim x As Long
  9.     Dim y As Long
  10.    
  11.     Application.ScreenUpdating = False
  12.     Application.DisplayAlerts = False
  13.    
  14.     arr = Sheet1.Range(Cells(1, 1), Cells(Sheet1.Range("a65536").End(xlUp).Row, Sheet1.Range("IV1").End(xlToLeft).Column))
  15.     My_path = ThisWorkbook.Path & ""
  16.     Workbooks.Open (My_path & "顾客信息登记表.xls")
  17.    
  18.     Set dic = CreateObject("scripting.dictionary")
  19.    
  20.     For x = 1 To 3
  21.         Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("c" & x + 3) = arr(2, x)
  22.     Next
  23.    
  24.     brr = Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b7:" & Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("IV7").End(xlToLeft).Address)
  25.    
  26.     For i = 1 To UBound(brr, 2)
  27.         dic.Item(brr(1, i)) = ""
  28.     Next

  29.     For i = 2 To UBound(arr)
  30.         If i = 2 Then
  31.             For x = 5 To UBound(arr) - 1
  32.                 dic.Item(arr(1, x)) = arr(i, x)
  33.             Next
  34.             
  35.             Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b" & Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b65536").End(xlUp).Row + 1).Resize(1, dic.Count) = dic.items
  36.             
  37.         ElseIf arr(i, 2) = arr(i - 1, 2) Then
  38.             For x = 5 To UBound(arr) - 1
  39.                 dic.Item(arr(1, x)) = arr(i, x)
  40.             Next
  41.             
  42.             Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b" & Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b65536").End(xlUp).Row + 1).Resize(1, dic.Count) = dic.items
  43.         ElseIf arr(i, 2) <> arr(i - 1, 2) Then
  44.         
  45.             Workbooks("顾客信息登记表.xls").SaveAs Filename:=My_path & Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("c5") & ".xls"
  46.             ActiveWorkbook.Close
  47.             Workbooks.Open (My_path & "顾客信息登记表.xls")
  48.             
  49.             For y = 1 To 3
  50.                 Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("c" & y + 3) = arr(i, y)
  51.             Next
  52.             For x = 5 To UBound(arr) - 1
  53.                 dic.Item(arr(1, x)) = arr(i, x)
  54.             Next
  55.             
  56.             Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b" & Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("b65536").End(xlUp).Row + 1).Resize(1, dic.Count) = dic.items
  57.         End If
  58.     Next
  59.    
  60.     Workbooks("顾客信息登记表.xls").SaveAs Filename:=My_path & Workbooks("顾客信息登记表.xls").Sheets("顾客信息").Range("c5") & ".xls"
  61.     ActiveWorkbook.Close
  62.    
  63.     Application.ScreenUpdating = True
  64.     Application.DisplayAlerts = True
  65. End Sub
复制代码


好了 自己试试看吧

客户信息表.rar

18.3 KB, 下载次数: 11

回复

使用道具 举报

 楼主| 发表于 2017-2-20 19:29 | 显示全部楼层
lygkkk 发表于 2017-2-20 18:24
好了 自己试试看吧

好的,非常感谢!我看看。
回复

使用道具 举报

 楼主| 发表于 2017-2-20 20:06 | 显示全部楼层
lygkkk 发表于 2017-2-20 18:24
好了 自己试试看吧

老师,Office 2013提示错误。
提示错误 office2013.PNG
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 03:03 , Processed in 0.650023 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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