VBA:从文件名到工作表名

因工作上的需求，想把同一文件下的文件名取来，取文件名中有规律的字符，在同个工作簿中，添加成一个个工作表名

就是将一个个文件名中零件代码部分当成工作表名
方法一：直取过来，并进行取值

Sub addnew()

Dim filepath As String, filename As String, thiswbname As String
Dim ljdm As Variant
Dim ws As Worksheet

Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False   '不显示警告信息

filepath = ThisWorkbook.Path & "\程序工时\"
filename = Dir(filepath & "*.xls")

Do While filename <> "" '判断文件名不为空时
  
    ljdm = LJXXtoDMMC(filename) '获取文件名中的零件代码

    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
    i = 0
    For Each ws In ThisWorkbook.Sheets
     If ws.Name = ljdm(1) Then
        i = 1
     End If
    Next
    '如果没有则新增
    If i = 0 Then
      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      ws.Name = ljdm(1)
    End If

filename = Dir()  ' 获取下一个文件名

Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub


'将零件信息拆分成代码和名称
Function LJXXtoDMMC(ljxx As String) As Variant
Dim values(1 To 2) As Variant

values(1) = Mid(ljxx, 1, 14)
values(2) = Mid(ljxx, 15, Len(ljxx))
LJXXtoDMMC = values

End Function

方法二：由于领导要求另外生成过一个文件“获取CNC程序工时”，里面是已经有零件代码了，所以可以通过字典的方法获取。

Sub addnew()

Dim SOURCEWB As Workbook
Dim SOURCEWS As Worksheet
Dim TARGETWB As Workbook
Dim TARGETWS As Worksheet
Dim filepath As String
Dim rowscount As Long
Dim rng As Range


''Set TARGETWS = ThisWorkbook.Worksheets("Sheet1") ''在Sheet1中调试用

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''获取源文件信息
filepath = ThisWorkbook.Path
f = Dir(filepath & "\获取CNC程序工时.xlsm")
 If f = "" Then
     MsgBox "源文件不存，请查看"
     Exit Sub
 Else
     Set SOURCEWB = Workbooks.Open(filepath & "\" & f, ReadOnly:=True)
 End If
Set SOURCEWS = SOURCEWB.Worksheets("所有程序工时")

rowscount = SOURCEWS.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = SOURCEWS.Range(Cells(2, 1), Cells(rowscount, 1))
k = rng.Count


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


''将数据装入字典
Dim dic As Object
Dim cell As Range
Dim uniqueValue As Variant
Set dic = CreateObject("Scripting.Dictionary")

For Each cell In rng
    If Not dic.Exists(cell.Value) And cell.Value <> "" Then
        dic.Add cell.Value, ""
    End If
Next cell


SOURCEWB.Close SaveChanges:=False ''关闭源文件

''''''''''''''''''''''''''
'''将字典中的数据复制出来，调试时使用
'i = 1
'For Each uniqueValue In dic
'    TARGETWS.Cells(i, 1).Value = uniqueValue
'    i = i + 1
'Next uniqueValue
'''''''''''''''''''''''''''

' 遍历工作簿中的所有工作表，检查是否存在同名工作表,没有则新增

For Each uniqueValue In dic
i = 0
  For Each ws In ThisWorkbook.Sheets
    If ws.Name = uniqueValue Then
    i = 1
    End If
  Next
If i = 0 Then
  Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
  ws.Name = uniqueValue
End If

Next

End Sub

效果如下