[已解决]代码修改需求烦请大侠帮忙急用

坏也是一种态度

拆分表中BCD及目录都好了还差个A表
总是搞不定，有哪位大侠帮忙修改下代码
以便可以用
在线等谢谢了



Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim d As Object
  Dim d1 As Object
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.SheetsInNewWorkbook = 5
  Set d = CreateObject("scripting.dictionary")
  Set d1 = CreateObject("scripting.dictionary")
  d1("B") = Array("b3:l5", 11, 6)
  d1("C") = Array("B2:r5", 17, 6)
  d1("D") = Array("B2:z4", 25, 5)
  For Each ws In Worksheets
    flg = Left(ws.Name, 1)
    If flg Like "[B-D]" Then
      brr = d1(flg)
      With ws
        r = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = .Range("b1:b" & r)
        For i = brr(2) To UBound(arr)
          If Not d.exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
          End If
          If Not d(arr(i, 1)).exists(ws.Name) Then
            Set d(arr(i, 1))(ws.Name) = .Range(brr(0))
          End If
          Set d(arr(i, 1))(ws.Name) = Union(d(arr(i, 1))(ws.Name), .Cells(i, 2).Resize(1, brr(1)))
        Next
      End With
    End If
  Next
  For Each aa In d.keys
    Set wb = Workbooks.Add
    With wb
      ThisWorkbook.Worksheets("目录及报表说明").UsedRange.Copy .Worksheets(1).Range("c2")
      Worksheets(1).Name = "目录及报表说明"
      m = 2
      For Each bb In d(aa).keys
        With Worksheets(m)
          .Name = bb
          d(aa)(bb).Copy .Range("b3")
        End With
        m = m + 1
      Next
      .SaveAs Filename:=ThisWorkbook.Path & "\" & "财务数据_" & aa & ".xls"
      .Close False
    End With
  Next
End Sub

最佳答案

月排行榜 / 总排行榜

grf1973

2015-10-27 13:26

请看附件。

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     Dim Sh As Worksheet, DelRng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet3.Range(Sheet3.[b6], Sheet3.[b6].End(xlDown))
   
5.     For i = 1 To UBound(arr)
   
6.         d(arr(i, 1)) = 1
   
7.     Next
   
8.     For i = 1 To UBound(arr)
   
9.         x = arr(i, 1)
   
10.          Sheets(Array("目录及报表说明", "A、2015年1-8月分行损益明细表", "B、2015年1-8月分行收入结构表", _
    
11.         "C、2015年1-8月分行变动费用明细表", "D、2015年1-8月支行收入结构及损益明细表")).Copy
    
12.         With ActiveSheet
    
13.             For Each Sh In ActiveWorkbook.Worksheets
    
14.                 r = Sh.[b65536].End(3).Row
    
15.                 brr = Sh.Range("b1:b" & r)
    
16.                 Set DelRng = Sh.Rows(65536)
    
17.                 For k = 1 To UBound(brr)
    
18.                     If d(brr(k, 1)) = 1 And brr(k, 1) <> x Then Set DelRng = Union(DelRng, Sh.Rows(k))
    
19.                 Next
    
20.                 DelRng.Delete
    
21.                 Set DelRng = Nothing
    
22.             Next
    
23.             ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & "财务数据_" & x & ".xls"
    
24.             ActiveWorkbook.Close
    
25.         End With
    
26.     Next
    
27. End Sub

复制代码

grf1973

请看附件。

坏也是一种态度

grf1973 发表于 2015-10-27 13:26
请看附件。

真是太感谢了，解决我大问题了

坏也是一种态度

grf1973 发表于 2015-10-27 13:26
请看附件。

大侠你看这个需求，在需求表里面输入姓名，相关关联的信息都自动出来
这个应该怎么做呀

grf1973

请看附件。户主姓名不唯一无法处理，比如“洪吉川”。

grf1973

此件为准。

坏也是一种态度

grf1973 发表于 2015-10-30 10:14
此件为准。

真是太感谢大侠了，十分感激