Excel VBAmacros在分号之前获取文本的子string
我在这里有工作代码。
在第（3）节中，它从特定标题下的单元格获取值并将其打印到主文件中。 这些值通常看起来像
TL-18273982; 10MM
TL-288762; 76DK
CT-576
N / A
我想抓取第一个分号之前的信息。 并不是所有的单元格都有一个分号，所以它可能需要if语句的if语句; 然后在其前面打印所有内容。
我一直在尝试使用分离function来做到这一点，但我不是很熟悉VBA，所以我遇到了一些麻烦。 有什么build议么？
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 如果你使用Splitfunction，你会爱上它 – > 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")
并改变这样的function：
'(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
下面的VBA代码片段演示了假设文本被input到“A1”单元中的可能的解决scheme（ 注意 ：它不需要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。 与您相关的额外问题在注释中：业务逻辑有点不清楚，但遵循该示例代码，可以修改为：
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
最好的祝福，
尝试类似的东西。我不确定你的variables，你可能需要调整它们。
您可以使用instr在string中find一个字符（例如，返回“[”的位置）。 然后你可以用mid来提取一个substing，使用']'和'['的位置。
openPos = instr (hc , "[") closePos = instr (hc , ";") if closePos = 0 then closePos = instr (hc , "]") end if dict = mid (hc , openPos+1, closePos - openPos - 1)