[已解决]vba 拆分工作表求助

鬼娃娃

sheets("录入表")是母工作表,希望按照A列的序号拆分工作表.

并且以后会经常按照顺序在下面添加客户,格式都不改变的,

拆分后的工作表格式如后边样表的格式

想做个按钮,每次添加客户之后,点下按钮就会自动生产以这个客户序号(A列)为工作表的名字

并且C列的公司名字能创建个超链接,点击能自动跳转到改公司所在的工作表

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-3 14:01

1. Sub 生成新表()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheet1.Range("a1:k" & Sheet1.[a65536].End(3).Row)
   
4.     For i = 3 To UBound(arr)
   
5.         d(Val(arr(i, 1))) = i
   
6.     Next
   
7.     a = arr(UBound(arr), 1)     '最末行序号（默认为以此序号新建表）
   
8.     xh = InputBox("请输入要生成表式的序号", , a)
   
9.     For Each sh In Worksheets
   
10.         x = x & "," & sh.Name
    
11.     Next
    
12.     If InStr("," & x, "," & xh & ",") Then MsgBox "工作表" & xh & "已存在": Exit Sub
    
13.     r = d(Val(xh))       '根据序号找到对应行r
    
14.     If r = 0 Then MsgBox "序号" & xh & "不存在": Exit Sub
    
15.     Sheets("表式").Copy after:=Sheets(Sheets.Count)
    
16.     With ActiveSheet
    
17.         .Name = xh
    
18.         .[a1] = arr(r, 3) '公司名
    
19.         .[b2] = xh  '序号
    
20.         .[b3].Resize(4, 1) = Application.Transpose(Array(arr(r, 5), arr(r, 7), arr(r, 6), arr(r, 4)))    '左四
    
21.         .[f3].Resize(4, 1) = Application.Transpose(Array(arr(r, 8), arr(r, 9), arr(r, 11), arr(r, 10)))     '右四
    
22.     End With
    
23.     Sheet1.Activate
    
24.     Sheet1.Hyperlinks.Add Sheet1.Cells(r, 3), Address:="", SubAddress:="'" & Sheets(xh).Name & "'" & "!A1"        'r行第三列加超链接
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 生成新表()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheet1.Range("a1:k" & Sheet1.[a65536].End(3).Row)
   
4.     For i = 3 To UBound(arr)
   
5.         d(Val(arr(i, 1))) = i
   
6.     Next
   
7.     a = arr(UBound(arr), 1)     '最末行序号（默认为以此序号新建表）
   
8.     xh = InputBox("请输入要生成表式的序号", , a)
   
9.     For Each sh In Worksheets
   
10.         x = x & "," & sh.Name
    
11.     Next
    
12.     If InStr("," & x, "," & xh & ",") Then MsgBox "工作表" & xh & "已存在": Exit Sub
    
13.     r = d(Val(xh))       '根据序号找到对应行r
    
14.     If r = 0 Then MsgBox "序号" & xh & "不存在": Exit Sub
    
15.     Sheets("表式").Copy after:=Sheets(Sheets.Count)
    
16.     With ActiveSheet
    
17.         .Name = xh
    
18.         .[a1] = arr(r, 3) '公司名
    
19.         .[b2] = xh  '序号
    
20.         .[b3].Resize(4, 1) = Application.Transpose(Array(arr(r, 5), arr(r, 7), arr(r, 6), arr(r, 4)))    '左四
    
21.         .[f3].Resize(4, 1) = Application.Transpose(Array(arr(r, 8), arr(r, 9), arr(r, 11), arr(r, 10)))     '右四
    
22.     End With
    
23.     Sheet1.Activate
    
24.     Sheet1.Hyperlinks.Add Sheet1.Cells(r, 3), Address:="", SubAddress:="'" & Sheets(xh).Name & "'" & "!A1"        'r行第三列加超链接
    
25. End Sub
    

复制代码