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

Posted 2023-02-22

【中文标题】Excel VBA宏获取分号前的文本子字符串

【英文标题】：Excel VBA Macro to get the substring of text before semicolon

【发布时间】：2015-08-24 07:13:53

【问题描述】：

我这里有工作代码。

在第 (3) 节中，它从特定标题下的单元格中获取值并将它们打印到主文件中。这些值通常看起来像

TL-18273982； 10MM

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

【参考方案1】：

尝试类似的方法。我不确定你的变量，你可能需要调整它们。

您可以使用 instr 在字符串中定位一个字符（例如返回 '[' 的位置）。然后，您可以使用 mid 提取替换，使用 ']' 和 '[' 的位置。

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

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

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

【参考方案2】：

如果你使用Split 函数，你会喜欢它 -> https://msdn.microsoft.com/en-us/library/6x627e5f%28v=vs.90%29.aspx

寻找这个例子：

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

编辑： 也许简单修改GetValues就可以解决问题？

将函数调用改为：

Set dict = GetValues(hc.Offset(1, 0), "SplitMe")

然后像这样改变函数：

'(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

【讨论】：

太棒了@Dawid。但是，我拥有的 TL-... 和 CT-... 等，每个文件最多可以有 50 个包含该信息的单元格，因此我无法逐个输入。您知道如何根据我在第 (3) 节中的代码将 String1 设置为等于当前单元格的值吗？

这非常有效。太感谢了。还有一个快速的问题，如果我想让它用分号和逗号分隔，我应该在哪里添加 , ？我尝试了一个 (v, ";" & ",") 并添加了另一行 spl = Split(v, ",") 并且这两个都取消了 ; 之后的信息。它需要自己的 If 语句吗？ @Dawid

没关系，我让它工作了。我只需要从 If Not IsMissing 复制并粘贴到最近的 End If 并将分号更改为逗号。谢谢！

如果你想用多个分隔符拆分，请阅读 -> experts-exchange.com/articles/1480/…

非常感谢，友好而简单 --> 我的情况只使用拆分选项就足够了，不需要修剪值："Split(Me.SampleInfo1.Value, "-")( 1)"

【参考方案3】：

以下 VBA 代码 sn-p 演示了假设文本输入“A1”单元格的可能解决方案（注意：它不需要 Split() 函数）：

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 可以扩展为循环遍历单元格范围（例如 A1 到 A10）：

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

希望这会有所帮助。

PS。与您在 cmets 中的其他问题相关：业务逻辑有点不清楚，但是按照该示例代码，可以将其修改为：

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

最好的问候，

【讨论】：

这绝对有帮助。您知道我如何将其与第 3 节中的代码集成吗？我很难让它们很好地啮合......到目前为止我有这个，我确信这是非常错误的。也很抱歉造成混淆， [] ws 只是应该指定一个单元格，它实际上并不存在。我将编辑 If dict.count > 0 Then Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) If (position > 0) Then substring = Replace(Left(Cells(1, 1), position - 1), ";", "") End If d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) End If

抱歉，在 cmets 中很难阅读代码。这是查看它的链接pastie.org/10231349。 @AlexBell

我已经扩展了我的答案。请检查它是否被接受，如果您有更多问题，请单独发布。最好的问候，

【参考方案4】：

考虑：

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

【讨论】：

我会试试这个！快速提问。你知道我如何利用第 (3) 节中的函数在当前单元格上运行函数吗？我无法弄清楚如何将它们联系在一起@Gary'sStudent