Excel Macro VBA pour obtenir la chaîne de texte avant le point-virgule

J'ai du code qui fonctionne ici.

Dans la section (3) il s'empare de valeurs à partir d'une cellule sous un en-tête spécifique et de les imprimer pour un dossier principal. Ces valeurs sont en général ressembler

TL-18273982; 10MM

TL-288762; 76DK

CT-576

N/A

Je voudrais prendre juste les informations avant le premier point-virgule. Pas toutes les cellules ont un point virgule en eux, de sorte qu'il aurait probablement besoin d'une instruction if le long des lignes de si ; ensuite imprimer le tout en face d'elle.

J'ai essayé d'utiliser une fonction de répartition pour le faire, mais je ne suis pas très expérimenté avec VBA, donc je vais avoir quelques problèmes. Des suggestions?

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