自动提取数据（并截取会计科目最末级明细科目，同时使一级二级科目字体加粗）

feiaoli

3楼重新上传了附件，请老师做一下VBA，谢谢！6楼代码已经解决，谢谢各位老师的关心！

feiaoli

" 经费支出明细 "表格自动提取 " 科目汇总 " 表格相应数据【并截取会计科目最末级明细科目，同时一级二级科目字体加粗。重新上传了附件，麻烦老师了！

feiaoli

dsmch 发表于 2017-1-22 15:52

非常感谢老师，问题已经解决。是excelhome的CC例例 老师不辞辛劳给我做的，看到老师的代码很简洁，只是想压缩一下文件大小和尽量使我可以多收藏一点知识，老师或许很忙，以后有问题还需要麻烦您的。谢谢您！【http://club.excelhome.net/thread-1325196-1-1.html】8、9楼！
excelhome的CC例例 老师的代码共享！

1. Private Sub Worksheet_Activate()
   
2.     Dim rng As Range, arA, arB, arC, k, x%, y%, i%, j%
   
3.     [ac4].CurrentRegion.Offset(4) = ""
   
4.     arA = Sheets("科目汇总").[b4].CurrentRegion
   
5.     arC = Array(14, 15, 18, 19, 26, 27)
   
6.     ReDim arB(1 To UBound(arA), 1 To 14)
   
7.     For x = 5 To UBound(arA)
   
8.         If CStr(Left(arA(x, 1), 3)) = "504" Then
   
9.             j = j + 1
   
10.             k = Split(arA(x, 3), "-")
    
11.             y = UBound(k): i = 0
    
12.             If y = 0 Or y = 1 Then
    
13.                 If rng Is Nothing Then
    
14.                     Set rng = Cells(j + 5, "AD")
    
15.                 Else
    
16.                     Set rng = Union(rng, Cells(j + 5, "AD"))
    
17.                 End If
    
18.             End If
    
19.             arB(j, 1) = arA(x, 1)
    
20.             arB(j, 2) = k(y)
    
21.             For y = 3 To 13 Step 2
    
22.                 arB(j, y) = arA(x, arC(i))
    
23.                 i = i + 1
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     With [ac6].Resize(j, 14)
    
28.          .Font.Bold = False
    
29.          .Value = arB
    
30.     End With
    
31.     rng.Font.Bold = True
    
32. End Sub

复制代码

feiaoli

修改一下代码也好，或者重新编辑代码也好，谢谢啦！

dsmch

1. Sub Macro1()
   
2. arr = Sheet1.UsedRange
   
3. Sheet2.Activate
   
4. [ac6:ap2000] = ""
   
5. [ad:ad].Font.Bold = False
   
6. s = 5: zf = "事业支出"
   
7. For i = 6 To UBound(arr)
   
8.     If InStr(arr(i, 3), zf) Then
   
9.         s = s + 1
   
10.         Cells(s, "ac") = arr(i, 1)
    
11.         Cells(s, "ad") = arr(i, 3)
    
12.         y = Split(arr(i, 3), "-")
    
13.         If UBound(y) < 2 Then Cells(s, "ad").Font.Bold = True
    
14.     End If
    
15. Next
    
16. End Sub

复制代码

feiaoli

dsmch 发表于 2017-1-22 15:52

谢谢老师简单明了爽气的代码，但是还有两个问题没有解决，1、没有代码的科目表不要提取（或许老师根据事业支出的主科目代码504来提取整行），2、没有截取最末级科目（如附件）3、没有提取数据（老师我说数据不是关键只是对您这样的老师来说的，对我纯白级别来说根本不会）。还请老师再给做一个简单明了的代码。