Sub 提取A2命名sheet()
Dim sh As Worksheet
On Error Resume Next
For Each sh In Worksheets
If sh.Visible = -1 Then '遍历可见sheet
a = sh.Cells(2, "A")
s = Split(a, "]") '按“]”分割
sh.Name = s(1) '提取第二组数据
End If
Next sh
End Sub
1、代码功能:提取A2单元格“]”后的内容,命名给当前sheet
2、代码使用方法:按alt+f11,弹出代码窗口。
![](https://video.ask-data.xyz/img.php?b=https://iknow-pic.cdn.bcebos.com/faf2b2119313b07eae8c90fe01d7912397dd8c17?x-bce-process=image%2Fresize%2Cm_lfit%2Cw_600%2Ch_800%2Climit_1%2Fquality%2Cq_85%2Fformat%2Cf_auto)
3、自定义部分:
①修改分割符:代码第7行
②修改提取范围:代码第8行(注:S(0),从0开始是第一组)
追问超赞的这个方法!
非常感谢!
话说,能不能再教我一下,把这些工作表单独拆分成Excel文件,并且文件名和工作表的名字都一致咋弄~
追答Sub 拆分工作表()
'功能:拆分可见sheet到指定目录,文件名与sheet名相同
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Dim sh As Worksheet
wbname = "111.xlsx" '指定要拆分的文件名
patth = "d:\" '指定拆分到哪里,默认D:\盘
For Each sh In Workbooks(wbname).Worksheets
If sh.Visible = xlSheetVisible Then
Set wb = Workbooks.Add
Workbooks(wbname).Sheets(sh.Name).Copy wb.Worksheets(1)
ActiveWorkbook.Worksheets("Sheet1").Delete
If sh.Name & ".xlsx" <> wbname Then '排除sheet名称与文件名相同
ActiveWorkbook.SaveAs patth & sh.Name & ".xlsx"
Else
ActiveWorkbook.SaveAs patth & sh.Name & " " & ".xlsx"
End If
ActiveWorkbook.Close True
End If
Next sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "完成!"
End Sub
这是拆分工作表的代码:
指定当前拆分的工作簿名称:代码7行
修改文件输出路径:代码8行