Excel精英培训网

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

[已解决]求助,修改宏

[复制链接]
发表于 2012-12-2 22:51 | 显示全部楼层 |阅读模式
老师更改下,拆分每个工作表K列不显示,每个表F列从F4单元开始加入公式=IF(COUNTIF(K$4:K$4,E4&"*")=1,"√","")
最佳答案
2012-12-3 20:23
  1. Sub 数据3()
  2.     Dim arr
  3.     Dim iRow&, i&, wbzb$
  4.    
  5.     '读取总表源数据
  6.     wbzb = "总表"
  7.     ThisWorkbook.Activate
  8.     With Worksheets(wbzb)
  9.         If Len(.[a3]) = 0 Then Exit Sub
  10.         '高级筛选,去除重复值
  11.         .Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
  12.         iRow = .Range("c" & Rows.Count).End(xlUp).Row
  13.         If iRow <= 3 Then Exit Sub  '最后一行数据行低于第3行位置就退出
  14.         arr = .Range("a3:i" & iRow)
  15.     End With
  16.    
  17.     'arr2数组存储数据
  18.     Dim dic As Object, arr2(), k&, j&
  19.     '数据列对应关系,arrZos源列号,arrMpos目标列号
  20.     Dim arrZPos, arrMPos, arrTemp
  21.     arrZPos = Array(4, 5, 6, 7, 8, 9)
  22.     arrMPos = Array(1, 2, 3, 4, 5, 10)
  23.    
  24.     '以支行网点名字存入字典
  25.     Set dic = CreateObject("Scripting.dictionary")
  26.     For i = 2 To UBound(arr)
  27.         If Not dic.exists(arr(i, 3)) Then
  28.             ReDim arr2(1 To 10, 1 To 1)
  29.             For j = LBound(arrZPos) To UBound(arrZPos)
  30.                 arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
  31.             Next
  32.             dic(arr(i, 3)) = Array(1, arr2) '0为存入个数,1为数组
  33.         Else
  34.             arrTemp = dic(arr(i, 3))
  35.             k = arrTemp(0) + 1
  36.             arr2 = arrTemp(1)
  37.             ReDim Preserve arr2(1 To 10, 1 To k)
  38.             For j = LBound(arrZPos) To UBound(arrZPos)
  39.                 arr2(arrMPos(j), k) = arr(i, arrZPos(j))
  40.             Next
  41.             dic(arr(i, 3)) = Array(k, arr2)
  42.         End If
  43.     Next

  44.     On Error Resume Next
  45.     Dim wb As Workbook
  46.     Dim wbname$, Slash$
  47.     wbname = "明细.xls"
  48.     Slash = Application.PathSeparator

  49.     Dim secAutomation As MsoAutomationSecurity
  50.     Set wb = Workbooks(wbname)
  51.     If Err.Number <> 0 Then
  52.         Err.Clear
  53.         MsgBox ThisWorkbook.Path & Slash & wb
  54.         '防止打开时运行宏
  55.         secAutomation = Application.AutomationSecurity
  56.         Application.AutomationSecurity = msoAutomationSecurityForceDisable
  57.         Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
  58.         If Err.Number <> 0 Then
  59.             MsgBox "打开 " & wb & " 出错"
  60.             Err.Clear
  61.             Exit Sub
  62.         End If
  63.     End If
  64.    
  65.     wb.Activate

  66.     Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
  67.     For Each keyitem In dic.keys
  68.         With Worksheets(keyitem)
  69.             If Err.Number = 0 Then
  70.                 .Range("d:e").NumberFormatLocal = "@"
  71.                 .Range("f:f").NumberFormatLocal = "G/通用格式"
  72.                  endrow = .Range("c" & Rows.Count).End(xlUp).Row = 3
  73.                 If endrow > 3 Then
  74.                     .Range("a4:j" & endrow).ClearContents
  75.                     .Range("a4:j" & endrow).Borders.LineStyle = xlNone
  76.                 End If
  77.                 endrow = 4
  78.                 arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
  79.                 .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
  80.                 endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
  81.                 .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"
  82.                 .Range("f" & endrow & ":f" & endrow2).FillDown
  83.                 End If
  84.             Err.Clear
  85.         End With
  86.     Next
  87.     Application.AutomationSecurity = msoAutomationSecurityByUI
  88. End Sub
复制代码

总表拆分到另一工作薄同名工作表1.zip

22.86 KB, 下载次数: 11

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2012-12-3 00:39 | 显示全部楼层
  1. Option Explicit

  2. Sub 数据()
  3.     Dim arr
  4.     Dim iRow&, i&
  5.    
  6.     iRow = Range("c" & Rows.Count).End(xlUp).Row
  7.     If iRow <= 3 Then Exit Sub
  8.    
  9.     arr = Range("a1:i" & iRow)
  10.     Dim dic As Object, arr2(), k&, j&
  11.     Dim arrZPos, arrMPos, arrTemp
  12.     arrZPos = Array(4, 5, 6, 7, 8, 9)
  13.     arrMPos = Array(1, 2, 3, 4, 5, 10)
  14.     Set dic = CreateObject("Scripting.dictionary")
  15.     For i = 4 To UBound(arr)
  16.         If Not dic.exists(arr(i, 3)) Then
  17.             ReDim arr2(1 To 10, 1 To 1)
  18.             For j = LBound(arrZPos) To UBound(arrZPos)
  19.                 arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
  20.             Next
  21.             dic(arr(i, 3)) = Array(1, arr2)
  22.         Else
  23.             arrTemp = dic(arr(i, 3))
  24.             k = arrTemp(0) + 1
  25.             arr2 = arrTemp(1)
  26.             ReDim Preserve arr2(1 To 10, 1 To k)
  27.             For j = LBound(arrZPos) To UBound(arrZPos)
  28.                 arr2(arrMPos(j), k) = arr(i, arrZPos(j))
  29.             Next
  30.             dic(arr(i, 3)) = Array(k, arr2)
  31.         End If
  32.     Next

  33.     On Error Resume Next
  34.     Dim wb As Workbook
  35.     Dim wbname$, Slash$
  36.     wbname = "明细.xls"
  37.     Slash = Application.PathSeparator

  38.     Set wb = Workbooks(wbname)
  39.     If Err.Number <> 0 Then
  40.         Err.Clear
  41.         MsgBox ThisWorkbook.Path & Slash & wb
  42.         Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
  43.         If Err.Number <> 0 Then
  44.             MsgBox "打开 " & wb & " 出错"
  45.             Err.Clear
  46.             Exit Sub
  47.         End If
  48.     End If
  49.     wb.Activate

  50.     Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
  51.     For Each keyitem In dic.keys
  52.         With Worksheets(keyitem)
  53.             If Err.Number = 0 Then
  54.                 Range("e:f").NumberFormatLocal = "@"
  55.                 endrow = .Range("c" & Rows.Count).End(xlUp).Row + 1
  56.                 arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
  57.                 .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
  58.                 endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
  59.                 .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:R4C[5],RC[-1]&""*"")=1,""√"","""")"
  60.                 .Range("f" & endrow & ":f" & endrow2).FillDown
  61.                
  62.             Else
  63.                 Err.Clear
  64.             End If
  65.         End With
  66.     Next
  67. End Sub
复制代码
F列的边框我就没加代码了。
回复

使用道具 举报

 楼主| 发表于 2012-12-3 01:24 | 显示全部楼层
本帖最后由 新会甜橙 于 2012-12-3 01:35 编辑
hwc2ycy 发表于 2012-12-3 00:39
F列的边框我就没加代码了。


老师,f列公式不行,另过滤g列重复,F4单元开始加入公式=IF(COUNTIF(K$4:K$4,E4&"*")=1,"√","").F5单元开始加入公式=IF(COUNTIF(K$4:K$5,E5&"*")=1,"√",""),如此类推
已重上附件望帮助

总表拆分到另一工作薄同名工作表1.zip

31.2 KB, 下载次数: 12

回复

使用道具 举报

发表于 2012-12-3 10:10 | 显示全部楼层
你又改数据源。上次还特意告诉你的,要注意加'号的问题。
回复

使用道具 举报

发表于 2012-12-3 10:48 | 显示全部楼层
本帖最后由 hwc2ycy 于 2012-12-3 10:53 编辑
新会甜橙 发表于 2012-12-3 01:24
老师,f列公式不行,另过滤g列重复,F4单元开始加入公式=IF(COUNTIF(K$4:K$4,E4&"*")=1,"√","").F5单元开 ...

K$4不加变成列固定,行不固定就成了$K4,这样填充的时候就能跟着变的。
回复

使用道具 举报

发表于 2012-12-3 10:53 | 显示全部楼层
还有一点,你要考虑的是以后数据在分到明细表时,是否要清除原来数据。
回复

使用道具 举报

 楼主| 发表于 2012-12-3 11:45 来自手机 | 显示全部楼层
hwc2ycy 发表于 2012-12-3 10:53
还有一点,你要考虑的是以后数据在分到明细表时,是否要清除原来数据。

还是老师想得周到,要清空数据,公式是从K4单元开始输入数据核对E列数据,对的在F列打勾,数据有重复要过滤,谢谢老师
回复

使用道具 举报

发表于 2012-12-3 13:02 | 显示全部楼层
  1. Sub 数据()
  2.     Dim arr
  3.     Dim iRow&, i&, wbzb$
  4.    
  5.     '读取总表源数据
  6.     wbzb = "总表"
  7.     ThisWorkbook.Activate
  8.     With Worksheets(wbzb)
  9.         If Len(.[a3]) = 0 Then Exit Sub
  10.         '高级筛选,去除重复值
  11.         .Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
  12.         iRow = .Range("c" & Rows.Count).End(xlUp).Row
  13.         If iRow <= 3 Then Exit Sub  '最后一行数据行低于第3行位置就退出
  14.         arr = .Range("a3:i" & iRow)
  15.     End With
  16.    
  17.     'arr2数组存储数据
  18.     Dim dic As Object, arr2(), k&, j&
  19.     '数据列对应关系,arrZos源列号,arrMpos目标列号
  20.     Dim arrZPos, arrMPos, arrTemp
  21.     arrZPos = Array(4, 5, 6, 7, 8, 9)
  22.     arrMPos = Array(1, 2, 3, 4, 5, 10)
  23.    
  24.     '以支行网点名字存入字典
  25.     Set dic = CreateObject("Scripting.dictionary")
  26.     For i = 2 To UBound(arr)
  27.         If Not dic.exists(arr(i, 3)) Then
  28.             ReDim arr2(1 To 10, 1 To 1)
  29.             For j = LBound(arrZPos) To UBound(arrZPos)
  30.                 arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
  31.             Next
  32.             dic(arr(i, 3)) = Array(1, arr2) '0为存入个数,1为数组
  33.         Else
  34.             arrTemp = dic(arr(i, 3))
  35.             k = arrTemp(0) + 1
  36.             arr2 = arrTemp(1)
  37.             ReDim Preserve arr2(1 To 10, 1 To k)
  38.             For j = LBound(arrZPos) To UBound(arrZPos)
  39.                 arr2(arrMPos(j), k) = arr(i, arrZPos(j))
  40.             Next
  41.             dic(arr(i, 3)) = Array(k, arr2)
  42.         End If
  43.     Next

  44.     On Error Resume Next
  45.     Dim wb As Workbook
  46.     Dim wbname$, Slash$
  47.     wbname = "明细.xls"
  48.     Slash = Application.PathSeparator

  49.     Dim secAutomation As MsoAutomationSecurity
  50.     Set wb = Workbooks(wbname)
  51.     If Err.Number <> 0 Then
  52.         Err.Clear
  53.         MsgBox ThisWorkbook.Path & Slash & wb
  54.         '防止打开时运行宏
  55.         secAutomation = Application.AutomationSecurity
  56.         Application.AutomationSecurity = msoAutomationSecurityForceDisable
  57.         Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
  58.         If Err.Number <> 0 Then
  59.             MsgBox "打开 " & wb & " 出错"
  60.             Err.Clear
  61.             Exit Sub
  62.         End If
  63.     End If
  64.    
  65.     wb.Activate

  66.     Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
  67.     For Each keyitem In dic.keys
  68.         With Worksheets(keyitem)
  69.             If Err.Number = 0 Then
  70.                 .Range("d:e").NumberFormatLocal = "@"
  71.                 .Range("f").NumberFormatLocal = "G/通用格式"
  72.                 endrow = .Range("c" & Rows.Count).End(xlUp).Row + 1
  73.                 arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
  74.                 .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
  75.                 endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
  76.                 .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"
  77.                 .Range("f" & endrow & ":f" & endrow2).FillDown
  78.                 With .Range("a" & 3 & ":j" & endrow2)
  79.                     .Borders(xlDiagonalDown).LineStyle = xlNone
  80.                     .Borders(xlDiagonalUp).LineStyle = xlNone
  81.                     With .Borders(xlEdgeLeft)
  82.                         .LineStyle = xlContinuous
  83.                         .ColorIndex = 0
  84.                         .TintAndShade = 0
  85.                         .Weight = xlThin
  86.                     End With
  87.                     With .Borders(xlEdgeTop)
  88.                         .LineStyle = xlContinuous
  89.                         .ColorIndex = 0
  90.                         .TintAndShade = 0
  91.                         .Weight = xlThin
  92.                     End With
  93.                     With .Borders(xlEdgeBottom)
  94.                         .LineStyle = xlContinuous
  95.                         .ColorIndex = 0
  96.                         .TintAndShade = 0
  97.                         .Weight = xlThin
  98.                     End With
  99.                     With .Borders(xlEdgeRight)
  100.                         .LineStyle = xlContinuous
  101.                         .ColorIndex = 0
  102.                         .TintAndShade = 0
  103.                         .Weight = xlThin
  104.                     End With
  105.                     With .Borders(xlInsideVertical)
  106.                         .LineStyle = xlContinuous
  107.                         .ColorIndex = 0
  108.                         .TintAndShade = 0
  109.                         .Weight = xlThin
  110.                     End With
  111.                     With .Borders(xlInsideHorizontal)
  112.                         .LineStyle = xlContinuous
  113.                         .ColorIndex = 0
  114.                         .TintAndShade = 0
  115.                         .Weight = xlThin
  116.                     End With
  117.                 End With
  118.             End If
  119.             Err.Clear
  120.         End With
  121.     Next
  122.     Application.AutomationSecurity = msoAutomationSecurityByUI
  123. End Sub
复制代码
回复

使用道具 举报

发表于 2012-12-3 13:11 | 显示全部楼层
  1. Sub 数据()
  2.     Dim arr
  3.     Dim iRow&, i&, wbzb$
  4.    
  5.     '读取总表源数据
  6.     wbzb = "总表"
  7.     ThisWorkbook.Activate
  8.     With Worksheets(wbzb)
  9.         If Len(.[a3]) = 0 Then Exit Sub
  10.         '高级筛选,去除重复值
  11.         .Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
  12.         iRow = .Range("c" & Rows.Count).End(xlUp).Row
  13.         If iRow <= 3 Then Exit Sub  '最后一行数据行低于第3行位置就退出
  14.         arr = .Range("a3:i" & iRow)
  15.     End With
  16.    
  17.     'arr2数组存储数据
  18.     Dim dic As Object, arr2(), k&, j&
  19.     '数据列对应关系,arrZos源列号,arrMpos目标列号
  20.     Dim arrZPos, arrMPos, arrTemp
  21.     arrZPos = Array(4, 5, 6, 7, 8, 9)
  22.     arrMPos = Array(1, 2, 3, 4, 5, 10)
  23.    
  24.     '以支行网点名字存入字典
  25.     Set dic = CreateObject("Scripting.dictionary")
  26.     For i = 2 To UBound(arr)
  27.         If Not dic.exists(arr(i, 3)) Then
  28.             ReDim arr2(1 To 10, 1 To 1)
  29.             For j = LBound(arrZPos) To UBound(arrZPos)
  30.                 arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
  31.             Next
  32.             dic(arr(i, 3)) = Array(1, arr2) '0为存入个数,1为数组
  33.         Else
  34.             arrTemp = dic(arr(i, 3))
  35.             k = arrTemp(0) + 1
  36.             arr2 = arrTemp(1)
  37.             ReDim Preserve arr2(1 To 10, 1 To k)
  38.             For j = LBound(arrZPos) To UBound(arrZPos)
  39.                 arr2(arrMPos(j), k) = arr(i, arrZPos(j))
  40.             Next
  41.             dic(arr(i, 3)) = Array(k, arr2)
  42.         End If
  43.     Next

  44.     On Error Resume Next
  45.     Dim wb As Workbook
  46.     Dim wbname$, Slash$
  47.     wbname = "明细.xls"
  48.     Slash = Application.PathSeparator

  49.     Dim secAutomation As MsoAutomationSecurity
  50.     Set wb = Workbooks(wbname)
  51.     If Err.Number <> 0 Then
  52.         Err.Clear
  53.         MsgBox ThisWorkbook.Path & Slash & wb
  54.         '防止打开时运行宏
  55.         secAutomation = Application.AutomationSecurity
  56.         Application.AutomationSecurity = msoAutomationSecurityForceDisable
  57.         Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
  58.         If Err.Number <> 0 Then
  59.             MsgBox "打开 " & wb & " 出错"
  60.             Err.Clear
  61.             Exit Sub
  62.         End If
  63.     End If
  64.    
  65.     wb.Activate

  66.     Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
  67.     For Each keyitem In dic.keys
  68.         With Worksheets(keyitem)
  69.             If Err.Number = 0 Then
  70.                 .Range("d:e").NumberFormatLocal = "@"
  71.                 .Range("f").NumberFormatLocal = "G/通用格式"
  72.                 endrow = .Range("c" & Rows.Count).End(xlUp).Row + 1
  73.                 arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
  74.                 .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
  75.                 endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
  76.                 .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"
  77.                 .Range("f" & endrow & ":f" & endrow2).FillDown
  78.                 With .Range("a" & 3 & ":j" & endrow2).Borders
  79.                         .LineStyle = xlContinuous
  80.                 End With
  81.                 .Range("a:j").Columns.AutoFit
  82.             End If
  83.             Err.Clear
  84.         End With
  85.     Next
  86.     Application.AutomationSecurity = msoAutomationSecurityByUI
  87. End Sub
复制代码
回复

使用道具 举报

发表于 2012-12-3 13:17 | 显示全部楼层
公式是放总表还是明细表啊,你的明细表里K列暂时无数据啊。
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 17:33 , Processed in 0.572653 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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