Excel VBA宏获取分号前文本的子字符串

我这里有工作代码

在第（3）节中，它从特定标题下的单元格中获取值，并将其打印到主文件中。这些值通常如下所示

TL-18273982；10毫米

TL-288762；76DK

CT-576

不适用

我只想获取第一个分号之前的信息。并非所有的单元格中都有分号，因此可能需要沿if行的if语句；然后在它前面打印所有内容

我一直在尝试使用分割函数来实现这一点，但我对VBA不是很有经验，所以我遇到了一些麻烦。有什么建议吗

Option Explicit

Sub LoopThroughDirectory()

    Const ROW_HEADER As Long = 10

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer
    Dim Height As Integer
    Dim RowLast As Long
    Dim f As String
    Dim dict As Object
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")

    'turn screen updating off - makes program faster
    Application.ScreenUpdating = False

    'location of the folder in which the desired TDS files are
    MyFolder = "C:\Users\trembos\Documents\TDS\progress\"

    'find the headers on the sheet
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")

    'create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'get the folder object
    Set objFolder = objFSO.GetFolder(MyFolder)
    i = 2


    'loop through directory file and print names
'(1)
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)

            'Open folder and file name, do not update links
            Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
            Set ws = WB.ActiveSheet
'(3)
                'find CUTTING TOOL on the source sheet
                Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
                If Not hc Is Nothing Then

                    Set dict = GetValues(hc.Offset(1, 0))
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        'add the values to the masterfile, column 3
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    End If
                Else
                    'header not found on source worksheet
                End If
'(4)
                'find HOLDER on the source sheet
                Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                If Not hc3 Is Nothing Then

                    Set dict = GetValues(hc3.Offset(1, 0))
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                        'add the values to the master list, column 2
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    End If
                Else
                    'header not found on source worksheet
                End If
'(5)
            With WB
               'print TDS information
                For Each ws In .Worksheets
                        'print the file name to Column 1
                        StartSht.Cells(i, 1) = objFile.Name
                        'print TDS name from J1 cell to Column 4
                        With ws
                            .Range("J1").Copy StartSht.Cells(i, 4)
                        End With
                        i = GetLastRowInSheet(StartSht) + 1
                'move to next file
                Next ws
'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With
        End If
    'move to next file
    Next objFile
    'turn screen updating back on
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = 1
'(7)
End Sub

'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range) As Object
    Dim dict As Object, rng As Range, c As Range, v
    Set dict = CreateObject("scripting.dictionary")
    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then
            dict.Add c.Address, v
        End If
    Next c
    Set GetValues = dict
End Function

'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
    Dim rv As Range, c As Range
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
        If Trim(c.Value) = sHeader Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function

'(10)
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function

'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            ret = 1
        End If
    End With
    GetLastRowInSheet = ret
End Function

选项显式
子循环目录（）
Const行标题长度=10
作为对象的Dim objFSO
将文件夹变暗为对象
Dim objFile作为对象
将MyFolder设置为字符串
Dim StartSht作为工作表，ws作为工作表
将WB设置为工作簿
作为整数的Dim i
将最后一行设置为整数，将eRoom设置为整数
变暗高度为整数
它能持续多久
作为字符串的Dim f
作为对象的Dim dict
调光hc作为量程，hc1作为量程，hc2作为量程，hc3作为量程，d作为量程
Set StartSht=工作簿（“masterfile.xlsm”）.Sheets（“Sheet1”）
'关闭屏幕更新-使程序更快
Application.ScreenUpdating=False
'所需TDS文件所在文件夹的位置
MyFolder=“C:\Users\trembos\Documents\TDS\progress\”
'查找工作表上的标题
设置hc1=头部电池（起始高度范围（“B1”），“支架”）
设定hc2=头槽（起始高度范围（“C1”），“刀具”）
'创建FileSystemObject的实例
设置objFSO=CreateObject（“Scripting.FileSystemObject”）
'获取文件夹对象
设置objFolder=objFSO.GetFolder（MyFolder）
i=2
'循环浏览目录文件并打印名称
'(1)
对于objFolder.Files中的每个objFile
如果LCase（Right（objFile.Name，3））=“xls”或LCase（Left（Right（objFile.Name，4），3））=“xls”，则
'(2)
'打开文件夹和文件名，不更新链接
设置WB=Workbooks.Open（文件名：=MyFolder&objFile.Name，UpdateLinks:=0）
设置ws=WB.ActiveSheet
'(3)
'在源工作表上查找切割工具
设置hc=收割台单元格（ws.Cells（第1行收割台），“切削刀具”）
如果不是的话，hc什么都不是
Set dict=GetValues（hc偏移量（1,0））
如果dict.count>0，则
Set d=StartSht.Cells（Rows.count，hc2.Column）。End（xlUp）。Offset（1，0）
'将值添加到主文件第3列
d、 调整大小（dict.count，1）.Value=Application.Transpose（dict.items）
如果结束
其他的
'在源工作表上找不到标题
如果结束
'(4)
'在源工作表上查找HOLDER
设置hc3=HeaderCell（ws.Cells（行标题，1），“HOLDER”）
如果不是，那么hc3什么都不是
Set dict=GetValues（hc3.Offset（1,0））
如果dict.count>0，则
Set d=StartSht.Cells（Rows.count，hc1.Column）。End（xlUp）。Offset（1，0）
'将值添加到主列表第2列
d、 调整大小（dict.count，1）.Value=Application.Transpose（dict.items）
如果结束
其他的
'在源工作表上找不到标题
如果结束
'(5)
与WB
'打印TDS信息
对于每个ws-In.工作表
'将文件名打印到第1列
StartSht.Cells（i，1）=objFile.Name
'将TDS名称从J1单元格打印到第4列
与ws
.范围（“J1”）.复制起始单元格（i，4）
以
i=获取最后一行数据表（StartSht）+1
'移动到下一个文件
下一个ws
'(6)
'关闭，不保存对打开文件的任何更改
.Close SaveChanges:=False
以
如果结束
'移动到下一个文件
下一个objFile
'重新打开屏幕更新
Application.ScreenUpdating=True
ActiveWindow.ScrollRow=1
'(7)
端接头
'(8)
'获取从单元格c开始的所有唯一列值
函数GetValues（作为范围）作为对象
Dim dict作为对象，rng作为范围，c作为范围，v
Set dict=CreateObject（“scripting.dictionary”）
对于ch.Parent.Range（ch，ch.Parent.Cells（Rows.count，ch.Column.End（xlUp））中的每个c。单元格
v=微调（c值）
如果Len（v）>0且不存在dict（v），则
地址，地址
如果结束
下一个c
设置GetValues=dict
端函数
'(9)
'查找行上的标题：如果未找到，则不返回任何内容
函数HeaderCell（rng作为范围，sHeader作为字符串）作为范围
尺寸rv As范围，c As范围
对于rng.Parent.Range（rng，rng.Parent.Cells（rng.Row，Columns.count）中的每个c.End（xlToLeft））.Cells
如果修剪（c.值）=剪切，则
设置rv=c
退出
如果结束
下一个c
设置水头室=rv
端函数
'(10)
函数GetLastRowInColumn（工作表为工作表，列为字符串）
使用工作表
GetLastRowInColumn=.Range（列和.Rows.count）.End（xlUp）.Row
以
端函数
'(11)
函数GetLastRowInSheet（工作表作为工作表）
暗网
使用工作表
如果Application.WorksheetFunction.CountA（.Cells）为0，则
ret=.Cells.Find（What:=“*”_
之后：=.范围（“A1”）_
看：=xlPart_
LookIn:=xl公式_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
其他的
Sub TestSplit()

Dim String1 As String
Dim Arr1 As Variant

String1 = "TL-18273982; 10MM"
Arr1 = Split(String1, ";")

Debug.Print "TEST1: String1=" & String1
Debug.Print "TEST1: Arr1(0)=" & Arr1(0)
Debug.Print "TEST1: Arr1(1)=" & Arr1(1)

String1 = "CT-576"
Arr1 = Split(String1, ";")
Debug.Print "TEST2: String1=" & String1
Debug.Print "TEST2: Arr1(0)=" & Arr1(0)

String1 = "N/A"
Arr1 = Split(String1, ";")
Debug.Print "TEST3: String1=" & String1
Debug.Print "TEST3: Arr1(0)=" & Arr1(0)

End Sub

TEST1: String1=TL-18273982; 10MM
TEST1: Arr1(0)=TL-18273982
TEST1: Arr1(1)= 10MM
TEST2: String1=CT-576
TEST2: Arr1(0)=CT-576
TEST3: String1=N/A
TEST3: Arr1(0)=N/A

'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
    Dim dict As Object, rng As Range, c As Range, v
    Dim spl As Variant
    Set dict = CreateObject("scripting.dictionary")
    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then

            If Not IsMissing(vSplit) Then
            spl = Split(v, ";")
            v = spl(0)
            End If

            dict.Add c.Address, v
        End If
    Next c
    Set GetValues = dict
End Function

Public Function PreSemicolon(sIN As String) As String
   If InStr(sIN, ";") = 0 Then
      PreSemicolon = ""
      Exit Function
   Else
      PreSemicolon = Split(sIN, ";")(0)
   End If
End Function

Sub GetSubstringDemo()
Dim position As Integer
Dim substring As String
position = InStr(Cells(1, 1), ";")
If (position > 0) Then
    substring = Left(Cells(1, 1), position - 1)
    'or use the following one to exclude "["
    'substring = Replace(Left(Cells(1, 1), position - 1), "[", "")
     Debug.Print substring
End If
End Sub

Sub GetSubstringDemo()
    Dim position As Integer
    Dim substring As String
    For i = 1 To 10
        position = InStr(Cells(i, 1), ";")
        If (position > 0) Then
            substring = Replace(Left(Cells(i, 1), position - 1), "[", "")
            Debug.Print substring
        End If
    Next i
End Sub

Set dict = GetValues(hc.Offset(1, 0))
If dict.count > 0 Then
    Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
    position = InStr(d.Value, ";")
    substring = Replace(Left(d.Value, position - 1), ";", "")     
    d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
End If

openPos = instr (hc , "[") closePos = instr (hc , ";")

   if closePos = 0 then
   closePos = instr (hc , "]")
   end if 

dict = mid (hc , openPos+1, closePos - openPos - 1)