[已解决]请求赐教！根据工作表表签名 ...

松儿

请求赐教！根据工作表表签名称建立工作表并可修改.rar (8.66 KB, 下载次数: 5)

2013-3-10 21:40 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-10 21:55

1. Sub 指量重命令工作表()
   
2.     Dim arr, strError As String
   
3.     Dim i As Integer
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.    
   
7.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8.     On Error Resume Next
   
9.     For i = 2 To UBound(arr)
   
10.         If Len(arr(i, 2)) > 0 Then
    
11.         
    
12.             If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
13.                 strError = strError & "工作表 " & arr(i, 1) & "不存在" & vbCr
    
14.             Else
    
15.                 Worksheets(arr(i, 1)).Name = arr(i, 2)
    
16.             End If
    
17.         End If
    
18.     Next
    
19.     Application.ScreenUpdating = True
    
20.     If Len(strError) > 0 Then
    
21.         MsgBox strError
    
22.     Else
    
23.         MsgBox "工作表批量重命名完成"
    
24.     End If
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 建立工作表()
   
2.     Dim arr, strError As String
   
3.     Dim i As Integer
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.    
   
7.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8.     On Error Resume Next
   
9.     For i = 2 To UBound(arr)
   
10.         If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
11.             Worksheets.Add after:=Worksheets(Worksheets.Count)
    
12.             ActiveSheet.Name = arr(i, 1)
    
13.         Else
    
14.             strError = strError & "工作表 " & arr(i, 1) & "已经存在" & vbCr
    
15.         End If
    
16.     Next
    
17.     Application.ScreenUpdating = True
    
18.     If Len(strError) > 0 Then
    
19.         MsgBox strError
    
20.     Else
    
21.         MsgBox "工作表批量建立完成"
    
22.     End If
    
23.     Application.ScreenUpdating = True
    
24. End Sub

复制代码

hwc2ycy

1. Sub 指量重命令工作表()
   
2.     Dim arr, strError As String
   
3.     Dim i As Integer
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.    
   
7.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8.     On Error Resume Next
   
9.     For i = 2 To UBound(arr)
   
10.         If Len(arr(i, 2)) > 0 Then
    
11.         
    
12.             If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
13.                 strError = strError & "工作表 " & arr(i, 1) & "不存在" & vbCr
    
14.             Else
    
15.                 Worksheets(arr(i, 1)).Name = arr(i, 2)
    
16.             End If
    
17.         End If
    
18.     Next
    
19.     Application.ScreenUpdating = True
    
20.     If Len(strError) > 0 Then
    
21.         MsgBox strError
    
22.     Else
    
23.         MsgBox "工作表批量重命名完成"
    
24.     End If
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

那么的帅

296646-VBA-根据工作表表签名称建立工作表并可修改.zip (20.2 KB, 下载次数: 11)

2013-3-10 22:00 上传

点击文件名下载附件

hwc2ycy

1. Sub 批量建立工作表()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : 批量建立工作表
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/3/10
   
6. ' Purpose   :
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9. '数组，错误消息
   
10.     Dim arr, strError As String
    
11.     '遍历数组用的循环变量
    
12.     Dim i As Integer
    
13. 
    
14.     '关闭屏幕刷新
    
15.     Application.ScreenUpdating = False
    
16. 
    
17.     '取源数据
    
18.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    
19. 
    
20.     '忽略错误，继续往下执行
    
21.     On Error Resume Next
    
22. 
    
23.     For i = 2 To UBound(arr)
    
24.         '判断要建立的工作表是否已经存在
    
25.         '不存在则建立，存在则生成错误消息
    
26.         If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
27.             Worksheets.Add after:=Worksheets(Worksheets.Count)
    
28.             ActiveSheet.Name = arr(i, 1)
    
29.         Else
    
30.             strError = strError & "工作表 " & arr(i, 1) & "已经存在" & vbCr
    
31.         End If
    
32.     Next
    
33. 
    
34.     '开启屏幕刷新
    
35.     Application.ScreenUpdating = True
    
36. 
    
37.     '判断错误消息字符串长度
    
38.     If Len(strError) > 0 Then
    
39.         MsgBox strError
    
40.     Else
    
41.         MsgBox "工作表批量建立完成"
    
42.     End If
    
43. 
    
44. End Sub
    
45. 
    
46. Sub 指量重命令工作表()
    
47. '---------------------------------------------------------------------------------------
    
48. ' Procedure : 指量重命令工作表
    
49. ' Author    : hwc2ycy
    
50. ' Date      : 2013/3/10
    
51. ' Purpose   :
    
52. '---------------------------------------------------------------------------------------
    
53. '
    
54. '数组，错误消息
    
55.     Dim arr, strError As String
    
56.     '遍历数组用的循环变量
    
57.     Dim i As Integer
    
58. 
    
59.     '关闭屏幕刷新
    
60.     Application.ScreenUpdating = False
    
61. 
    
62.     '取源数据
    
63.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    
64.     '忽略错误，继续往下执行
    
65.     On Error Resume Next
    
66.     For i = 2 To UBound(arr)
    
67.         '判断新工作表名是否有效
    
68.         If Len(arr(i, 2)) > 0 Then
    
69.             '检测要重命名的工作表是否存在
    
70.             If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
71.                 '不存在，则生成错误消息提示
    
72.                 strError = strError & "工作表 " & arr(i, 1) & "不存在" & vbCr
    
73.             Else
    
74.                 '重命名
    
75.                 Worksheets(arr(i, 1)).Name = arr(i, 2)
    
76.             End If
    
77.         End If
    
78.     Next
    
79. 
    
80.     '开启屏幕刷新
    
81.     Application.ScreenUpdating = True
    
82. 
    
83.     '判断错误消息字符串长度
    
84.     If Len(strError) > 0 Then
    
85.         MsgBox strError
    
86.     Else
    
87.         MsgBox "工作表批量重命名完成"
    
88.     End If
    
89. End Sub

复制代码

hwc2ycy

批量重命名忘了检测新名称了。

1. Sub 批量建立工作表()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : 批量建立工作表
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/3/10
   
6. ' Purpose   :
   
7. '---------------------------------------------------------------------------------------
   
8. 
   
9. '数组，错误消息
   
10.     Dim arr, strError As String
    
11.     '遍历数组用的循环变量
    
12.     Dim i As Integer
    
13. 
    
14.     '关闭屏幕刷新
    
15.     Application.ScreenUpdating = False
    
16. 
    
17.     '取源数据
    
18.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    
19. 
    
20.     '忽略错误，继续往下执行
    
21.     On Error Resume Next
    
22. 
    
23.     For i = 2 To UBound(arr)
    
24.         '判断要建立的工作表是否已经存在
    
25.         '不存在则建立，存在则生成错误消息
    
26.         If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
27.             Worksheets.Add after:=Worksheets(Worksheets.Count)
    
28.             ActiveSheet.Name = arr(i, 1)
    
29.         Else
    
30.             strError = strError & "工作表 " & arr(i, 1) & " 已经存在" & vbCr
    
31.         End If
    
32.     Next
    
33. 
    
34.     '开启屏幕刷新
    
35.     Application.ScreenUpdating = True
    
36. 
    
37.     '判断错误消息字符串长度
    
38.     If Len(strError) > 0 Then
    
39.         MsgBox strError
    
40.     Else
    
41.         MsgBox "工作表批量建立完成"
    
42.     End If
    
43. 
    
44. End Sub
    
45. 
    
46. Sub 指量重命令工作表()
    
47. '---------------------------------------------------------------------------------------
    
48. ' Procedure : 指量重命令工作表
    
49. ' Author    : hwc2ycy
    
50. ' Date      : 2013/3/10
    
51. ' Purpose   :
    
52. '---------------------------------------------------------------------------------------
    
53. 
    
54. '数组，错误消息
    
55.     Dim arr, strError As String
    
56.     '遍历数组用的循环变量
    
57.     Dim i As Integer
    
58. 
    
59.     '关闭屏幕刷新
    
60.     Application.ScreenUpdating = False
    
61. 
    
62.     '取源数据
    
63.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    
64.     '忽略错误，继续往下执行
    
65.     On Error Resume Next
    
66.     For i = 2 To UBound(arr)
    
67.         '判断新工作表名是否有效
    
68.         If Len(arr(i, 2)) > 0 Then
    
69.             '检测要重命名的工作表是否存在
    
70.             If Len(Worksheets(arr(i, 1)).Name) = 0 Then
    
71.                 '不存在，则生成错误消息提示
    
72.                 strError = strError & "工作表 " & arr(i, 1) & " 不存在" & vbCr
    
73.             Else
    
74.                 '检测新名称工作表是否存在
    
75.                 If Len(Worksheets(arr(i, 2)).Name) = 0 Then
    
76.                     '重命名
    
77.                     Worksheets(arr(i, 1)).Name = arr(i, 2)
    
78.                 Else
    
79.                     '存在，则生成错误消息提示
    
80.                     strError = strError & "工作表 " & arr(i, 2) & " 已经存在" & vbCr
    
81.                 End If
    
82. 
    
83.             End If
    
84.         End If
    
85.     Next
    
86. 
    
87.     '开启屏幕刷新
    
88.     Application.ScreenUpdating = True
    
89. 
    
90.     '判断错误消息字符串长度
    
91.     If Len(strError) > 0 Then
    
92.         MsgBox strError
    
93.     Else
    
94.         MsgBox "工作表批量重命名完成"
    
95.     End If
    
96. End Sub
    

复制代码

hwc2ycy

请求赐教！根据工作表表签名称建立工作表并可修改.rar (29.11 KB, 下载次数: 9)

2013-3-10 22:09 上传

点击文件名下载附件