设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 想各位帮忙一下！
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1922|回复: 5

[已解决]想各位帮忙一下！

[复制链接]
发表于 2013-7-5 14:29 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
各位大大，我刚开始学VBA，我工作的时候有两个表，分别是“购销-吉之岛”和“代销-吉之岛”，里面分别是不同店号的金额。我想用VBA做到以下效果：
1、以不同店号批量新建工作表，每个店分别是以“购销-店号”及“代销-店号”为表名；
2、然后将“购销-吉之岛”、“代销-吉之岛”的数据分别复制到“购销-店号”、“代销-店号”的表中；
3、最后将相同店号的购销和代销两个表合成一个工作薄。

恳请各位大大的帮忙，帮我在表中录制宏或者给我一些教材，谢谢了！！！
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2013-7-5 16:22
  1. Sub 多表合并拆散()
  2. '源数据
  3.     Dim arr
  4.     '工作表名，临时字符串
  5.     Dim strShtname As String, strTemp As String
  6.     '工作簿循环，数组循环
  7.     Dim i As Integer, j As Long
  8.     '单元格
  9.     Dim rg As Range
  10.     '字典对象
  11.     Dim objDic As Object, objDicKeyItem

  13.     On Error GoTo ErrorHandler


  16.     '关属性，提速
  17.     With Application
  18.         .ScreenUpdating = False
  19.         .DisplayAlerts = False
  20.         .EnableEvents = False
  21.         .Calculation = xlCalculationManual
  22.     End With


  25.     '先清空工作表内原有内容
  26.     For i = 3 To Worksheets.Count
  27.         Worksheets(i).UsedRange.ClearContents
  28.     Next

  30.     '创建字典
  31.     Set objDic = CreateObject("scripting.dictionary")

  33.     For i = 1 To 2
  34.         '取工作表名
  35.         strShtname = Worksheets(i).Name
  36.         '取工作表名中-号前的文本
  37.         strTemp = Left(strShtname, InStr(strShtname, "-") - 1)

  39.         '读取源数据
  40.         arr = Worksheets(i).Range("a1").CurrentRegion.Value

  42.         '数组循环
  43.         For j = LBound(arr) + 1 To UBound(arr)
  44.             '字典嵌套字典
  45.             If Not objDic.exists(arr(j, 1)) Then
  46.                 objDic.Add arr(j, 1), CreateObject("scripting.dictionary")
  47.             End If
  48.             objDic(arr(j, 1))(strTemp & "-" & arr(j, 1)) = ""

  50.             '检测工作表是否存不，不存在则创建

  52.             If Not HasWorksheet(strTemp & "-" & arr(j, 1)) Then
  53.                 Worksheets.Add after:=Worksheets(Worksheets.Count)
  54.                 ActiveSheet.Name = strTemp & "-" & arr(j, 1)
  55.             End If
  56.             '写入内容
  57.             With Worksheets(strTemp & "-" & arr(j, 1))
  58.                 Set rg = .Cells(Rows.Count, 1).End(xlUp)
  59.                 If rg.Row = 1 Then
  60.                     rg.Resize(, 2).Value = Array("店号", "金额")
  61.                 End If
  62.                 rg.Offset(1).Resize(, 2).Value = Array(arr(j, 1), arr(j, 2))
  63.             End With
  64.         Next
  65.     Next


  68.     '导出同店铺号的购销与代销
  69.     For Each objDicKeyItem In objDic.keys
  70.         Worksheets(objDic(objDicKeyItem).keys).Copy
  71.         ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & objDicKeyItem & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
  72.         'Debug.Print ActiveWorkbook.FullName
  73.         ActiveWorkbook.Close False
  74.     Next

  76.     '开属性,还原
  77.     With Application
  78.         .ScreenUpdating = True
  79.         .DisplayAlerts = True
  80.         .EnableEvents = True
  81.         .Calculation = xlCalculationAutomatic
  82.     End With
  83.     MsgBox "导出成功"
  84.     Exit Sub

  86. ErrorHandler:
  87.     MsgBox Err.Number & vbCrLf & _
  88.            Err.Description
  89.     If ActiveWorkbook.Name <> ThisWorkbook.Name Then
  90.         ActiveWorkbook.Close False
  91.     End If

  93.     With Application
  94.         .ScreenUpdating = True
  95.         .DisplayAlerts = True
  96.         .EnableEvents = True
  97.         .Calculation = xlCalculationAutomatic
  98.     End With

  100. End Sub

  102. Function HasWorksheet(strShtname As String) As Boolean
  103.     On Error Resume Next
  104.     If Len(Worksheets(strShtname).Name) = 0 Then
  105.         HasWorksheet = False
  106.         Err.Clear
  107.     Else
  108.         HasWorksheet = True
  109.     End If
  110. End Function
复制代码

Book2.rar

14.86 KB, 下载次数: 17
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-7-5 15:47 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub tst()
  2. '源数据
  3.     Dim arr
  4.     '工作表名，临时字符串
  5.     Dim strShtname As String, strTemp As String
  6.     '工作簿循环，数组循环
  7.     Dim i As Integer, j As Long
  8.     '单元格
  9.     Dim rg As Range
  10.     '工作表名数组字符串
  11.     Dim strShtArr As String, arrSheet
  12.     '字典对象
  13.     Dim objDic As Object, objDicKeyItem

  15.     '关属性，提速
  16.     With Application
  17.         .ScreenUpdating = False
  18.         .DisplayAlerts = False
  19.         .EnableEvents = False
  20.         .Calculation = xlCalculationManual
  21.     End With


  24.     '先清空工作表内原有内容
  25.     For i = 3 To Worksheets.Count
  26.         Worksheets(i).UsedRange.ClearContents
  27.     Next
  28.     '创建字典
  29.     Set objDic = CreateObject("scripting.dictionary")

  31.     For i = 1 To 2
  32.         '取工作表名
  33.         strShtname = Worksheets(i).Name
  34.         '取工作表名中-号前的文本
  35.         strTemp = Left(strShtname, InStr(strShtname, "-") - 1)

  37.         '读取源数据
  38.         arr = Worksheets(i).Range("a1").CurrentRegion.Value
  39.         '添加\，
  40.         strShtArr = strShtArr & strTemp & "\,"

  42.         '数组循环
  43.         For j = LBound(arr) + 1 To UBound(arr)
  44.             '添加店铺号
  45.             objDic(arr(j, 1)) = ""
  46.             '检测工作表是否存不，不存在则创建
  47.             If Not HasWorksheet(strTemp & "-" & arr(j, 1)) Then
  48.                 Worksheets.Add after:=Worksheets(Worksheets.Count)
  49.                 ActiveSheet.Name = strTemp & "-" & arr(j, 1)
  50.             End If
  51.             '写入内容
  52.             With Worksheets(strTemp & "-" & arr(j, 1))
  53.                 Set rg = .Cells(Rows.Count, 1).End(xlUp)
  54.                 If rg.Row = 1 Then
  55.                     rg.Resize(, 2).Value = Array("店号", "金额")
  56.                 End If
  57.                 rg.Offset(1).Resize(, 2).Value = Array(arr(j, 1), arr(j, 2))
  58.             End With
  59.         Next
  60.     Next

  62.     '导出同店铺号的购销与代销
  63.     For Each objDicKeyItem In objDic.keys
  64.         strTemp = Replace(Left(strShtArr, Len(strShtArr) - 1), "", "-" & objDicKeyItem)
  65.         arrSheet = Split(strTemp, ",")
  66.         Worksheets(arrSheet).Copy
  67.         ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & objDicKeyItem & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
  68.         Debug.Print ActiveWorkbook.FullName
  69.         ActiveWorkbook.Close False
  70.     Next
  71.     '开属性,还原
  72.     With Application
  73.         .ScreenUpdating = True
  74.         .DisplayAlerts = True
  75.         .EnableEvents = True
  76.         .Calculation = xlCalculationAutomatic
  77.     End With
  78.     MsgBox "导出成功"
  79. End Sub

  81. Function HasWorksheet(strShtname As String) As Boolean
  82.     On Error Resume Next
  83.     If Len(Worksheets(strShtname).Name) = 0 Then
  84.         HasWorksheet = False
  85.         Err.Clear
  86.     Else
  87.         HasWorksheet = True
  88.     End If
  89. End Function
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-7-5 15:48 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
代码里有个BUG，当一个店铺号在两个表里不同时存在时，会报错，呆会再改。
另外还没有做错误处理。

回复

使用道具 举报

 楼主| 发表于 2013-7-5 16:04 | 显示全部楼层
hwc2ycy 发表于 2013-7-5 15:48
代码里有个BUG，当一个店铺号在两个表里不同时存在时，会报错，呆会再改。
另外还没有做错误处理。

谢谢楼主！！！！！{:021:}
我要慢慢研究一下！！
太感谢了！！！！{:171:}
回复

使用道具 举报

hwc2ycy
发表于 2013-7-5 16:22 | 显示全部楼层    本楼为最佳答案   
  1. Sub 多表合并拆散()
  2. '源数据
  3.     Dim arr
  4.     '工作表名，临时字符串
  5.     Dim strShtname As String, strTemp As String
  6.     '工作簿循环，数组循环
  7.     Dim i As Integer, j As Long
  8.     '单元格
  9.     Dim rg As Range
  10.     '字典对象
  11.     Dim objDic As Object, objDicKeyItem

  13.     On Error GoTo ErrorHandler


  16.     '关属性，提速
  17.     With Application
  18.         .ScreenUpdating = False
  19.         .DisplayAlerts = False
  20.         .EnableEvents = False
  21.         .Calculation = xlCalculationManual
  22.     End With


  25.     '先清空工作表内原有内容
  26.     For i = 3 To Worksheets.Count
  27.         Worksheets(i).UsedRange.ClearContents
  28.     Next

  30.     '创建字典
  31.     Set objDic = CreateObject("scripting.dictionary")

  33.     For i = 1 To 2
  34.         '取工作表名
  35.         strShtname = Worksheets(i).Name
  36.         '取工作表名中-号前的文本
  37.         strTemp = Left(strShtname, InStr(strShtname, "-") - 1)

  39.         '读取源数据
  40.         arr = Worksheets(i).Range("a1").CurrentRegion.Value

  42.         '数组循环
  43.         For j = LBound(arr) + 1 To UBound(arr)
  44.             '字典嵌套字典
  45.             If Not objDic.exists(arr(j, 1)) Then
  46.                 objDic.Add arr(j, 1), CreateObject("scripting.dictionary")
  47.             End If
  48.             objDic(arr(j, 1))(strTemp & "-" & arr(j, 1)) = ""

  50.             '检测工作表是否存不，不存在则创建

  52.             If Not HasWorksheet(strTemp & "-" & arr(j, 1)) Then
  53.                 Worksheets.Add after:=Worksheets(Worksheets.Count)
  54.                 ActiveSheet.Name = strTemp & "-" & arr(j, 1)
  55.             End If
  56.             '写入内容
  57.             With Worksheets(strTemp & "-" & arr(j, 1))
  58.                 Set rg = .Cells(Rows.Count, 1).End(xlUp)
  59.                 If rg.Row = 1 Then
  60.                     rg.Resize(, 2).Value = Array("店号", "金额")
  61.                 End If
  62.                 rg.Offset(1).Resize(, 2).Value = Array(arr(j, 1), arr(j, 2))
  63.             End With
  64.         Next
  65.     Next


  68.     '导出同店铺号的购销与代销
  69.     For Each objDicKeyItem In objDic.keys
  70.         Worksheets(objDic(objDicKeyItem).keys).Copy
  71.         ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & objDicKeyItem & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
  72.         'Debug.Print ActiveWorkbook.FullName
  73.         ActiveWorkbook.Close False
  74.     Next

  76.     '开属性,还原
  77.     With Application
  78.         .ScreenUpdating = True
  79.         .DisplayAlerts = True
  80.         .EnableEvents = True
  81.         .Calculation = xlCalculationAutomatic
  82.     End With
  83.     MsgBox "导出成功"
  84.     Exit Sub

  86. ErrorHandler:
  87.     MsgBox Err.Number & vbCrLf & _
  88.            Err.Description
  89.     If ActiveWorkbook.Name <> ThisWorkbook.Name Then
  90.         ActiveWorkbook.Close False
  91.     End If

  93.     With Application
  94.         .ScreenUpdating = True
  95.         .DisplayAlerts = True
  96.         .EnableEvents = True
  97.         .Calculation = xlCalculationAutomatic
  98.     End With

  100. End Sub

  102. Function HasWorksheet(strShtname As String) As Boolean
  103.     On Error Resume Next
  104.     If Len(Worksheets(strShtname).Name) = 0 Then
  105.         HasWorksheet = False
  106.         Err.Clear
  107.     Else
  108.         HasWorksheet = True
  109.     End If
  110. End Function
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-7-8 16:36 | 显示全部楼层
hwc2ycy 发表于 2013-7-5 16:22

感谢班长吖！！
我还要慢慢摸索一下，把它运用到另外一些表格上！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-20 14:50 , Processed in 0.190431 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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