|
老师更改下,拆分每个工作表K列不显示,每个表F列从F4单元开始加入公式=IF(COUNTIF(K$4:K$4,E4&"*")=1,"√","")
- Sub 数据3()
- Dim arr
- Dim iRow&, i&, wbzb$
-
- '读取总表源数据
- wbzb = "总表"
- ThisWorkbook.Activate
- With Worksheets(wbzb)
- If Len(.[a3]) = 0 Then Exit Sub
- '高级筛选,去除重复值
- .Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
- iRow = .Range("c" & Rows.Count).End(xlUp).Row
- If iRow <= 3 Then Exit Sub '最后一行数据行低于第3行位置就退出
- arr = .Range("a3:i" & iRow)
- End With
-
- 'arr2数组存储数据
- Dim dic As Object, arr2(), k&, j&
- '数据列对应关系,arrZos源列号,arrMpos目标列号
- Dim arrZPos, arrMPos, arrTemp
- arrZPos = Array(4, 5, 6, 7, 8, 9)
- arrMPos = Array(1, 2, 3, 4, 5, 10)
-
- '以支行网点名字存入字典
- Set dic = CreateObject("Scripting.dictionary")
- For i = 2 To UBound(arr)
- If Not dic.exists(arr(i, 3)) Then
- ReDim arr2(1 To 10, 1 To 1)
- For j = LBound(arrZPos) To UBound(arrZPos)
- arr2(arrMPos(j), 1) = arr(i, arrZPos(j))
- Next
- dic(arr(i, 3)) = Array(1, arr2) '0为存入个数,1为数组
- Else
- arrTemp = dic(arr(i, 3))
- k = arrTemp(0) + 1
- arr2 = arrTemp(1)
- ReDim Preserve arr2(1 To 10, 1 To k)
- For j = LBound(arrZPos) To UBound(arrZPos)
- arr2(arrMPos(j), k) = arr(i, arrZPos(j))
- Next
- dic(arr(i, 3)) = Array(k, arr2)
- End If
- Next
- On Error Resume Next
- Dim wb As Workbook
- Dim wbname$, Slash$
- wbname = "明细.xls"
- Slash = Application.PathSeparator
- Dim secAutomation As MsoAutomationSecurity
- Set wb = Workbooks(wbname)
- If Err.Number <> 0 Then
- Err.Clear
- MsgBox ThisWorkbook.Path & Slash & wb
- '防止打开时运行宏
- secAutomation = Application.AutomationSecurity
- Application.AutomationSecurity = msoAutomationSecurityForceDisable
- Set wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)
- If Err.Number <> 0 Then
- MsgBox "打开 " & wb & " 出错"
- Err.Clear
- Exit Sub
- End If
- End If
-
- wb.Activate
- Dim arrKey, wbZong$, keyitem, endrow2&, endrow&
- For Each keyitem In dic.keys
- With Worksheets(keyitem)
- If Err.Number = 0 Then
- .Range("d:e").NumberFormatLocal = "@"
- .Range("f:f").NumberFormatLocal = "G/通用格式"
- endrow = .Range("c" & Rows.Count).End(xlUp).Row = 3
- If endrow > 3 Then
- .Range("a4:j" & endrow).ClearContents
- .Range("a4:j" & endrow).Borders.LineStyle = xlNone
- End If
- endrow = 4
- arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))
- .Range("a" & endrow).Resize(UBound(arr2), 10) = arr2
- endrow2 = .Range("c" & Rows.Count).End(xlUp).Row
- .Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"
- .Range("f" & endrow & ":f" & endrow2).FillDown
- End If
- Err.Clear
- End With
- Next
- Application.AutomationSecurity = msoAutomationSecurityByUI
- End Sub
复制代码
|
|