给定一个字符串，我想提取一些文本

Question

Given a list of strings, I want to divide the strings into different columns. The strings does not always comes in the same format, so I cannot use the same approach each time. I am trying to put the LC-XXXXXX in column B, then delete the "s" and put the text after the "s" and between the "^" or the "." (whatever the string contains) into column C

I am running a "for loop" for each string in which is saved as an array and looks something like this:

I have use the split, trim and mid commands but with no success.

With Sheets("TELECOM")
.Range("A14", "I305").ClearContents
For Each objFile In objFolder.Files
On Error Resume Next
    If InStr(objFile.Name, "LC-9") > 0 And InStr(objFile.Type, "DWG File") > 0 Then
        drwn = objFile.Name
        .Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here
        values = Array(drwn)
        Set re = CreateObject("vbscript.regexp")
        pattern = "(s\d+)"
    For i = LBound(values) To UBound(values)
        .Cells(r, 3) = Replace$(drwn, "s", vbNullString)
    Next
    r = r + 1
    End With

    Public Function GetId(ByVal re As Object, ByVal s As String, ByVal pattern As String) As String
With re
    .Global = True
    .MultiLine = True
    .IgnoreCase = False '? True if case insensitive
    .pattern = pattern
    If .test(s) Then
        GetId = .Execute(s)(0).SubMatches(0)
    End If
End With

End Function

I would like to take the list of stings and put the LC-XXXXX in column B and the sheet number (numbers between the "s" and the "^" or sometimes the ".dwg" or ".pdf") into a column C

NEW EDIT 04/06/2019

New Edit 04/07/2019

Main Code Sub GetIssued() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object

Dim openPos As Integer
Dim closePos As Integer

Dim sh As Object

Dim drwn, SheetNum

Set objFSO = CreateObject("scripting.FileSystemObject")

r = 14


fle = ThisWorkbook.Sheets("Header Info").Range("D11") &  
"\Design\Substation\CADD\Working\COMM\"

Set objFolder = objFSO.GetFolder(fle)

Set x1Book = ActiveWorkbook 'Using this Activeworkbook
Set sh = x1Book.Sheets("TELECOM") 'Using this particular sheet
With Sheets("TELECOM")
.Range("A14", "I305").ClearContents
For Each objFile In objFolder.Files
On Error Resume Next

If InStr(objFile.Name, "LC-9") > 0 And InStr(objFile.Type, "DWG                 
File") > 0 Then 'PEDs, Single Line, Cable and Wiring, Jumper and     
Interconnection
        .Cells(r, 9) = objFile.Name 'Testing Purposes
        drwn = Array(.Cells(r, 9).Value)
        .Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the 
drawing number and placing it here

        '-----------------------------------------------------------
        'Trying to Insert InstrMacro here
        '------------------------------------------------------------

        r = r + 1

        ElseIf InStr(objFile.Name, "MC-9") > 0 And InStr(objFile.Type, "DWG File") > 0 Then 'Cable List
        .Cells(r, 9) = objFile.Name 'Testing Purposes
        drwn = .Cells(r, 9).Value
        .Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here 

        '-----------------------------------------------------------
        'Trying to Insert InstrMacro here
        '------------------------------------------------------------

        r = r + 1

        ElseIf InStr(objFile.Name, "BMC-") > 0 And InStr(objFile.Type, "Adobe Acrobat Document") > 0 Then 'Bill of Materials
        .Cells(r, 9) = objFile.Name 'Testing Purposes
        drwn = .Cells(r, 9).Value
        .Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here 

        '-----------------------------------------------------------
        'Trying to Insert InstrMacro here
        '------------------------------------------------------------

        r = r + 1

        ElseIf InStr(objFile.Name, "CSR") > 0 And InStr(objFile.Type, "DWG") > 0 Then 'Single Line Diagram
        .Cells(r, 9) = objFile.Name 'Testing Purposes
        drwn = .Cells(r, 9).Value
        .Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here

        '---------------------------------------------------------
        'Trying to Insert InstrMacro here
        '------------------------------------------------------------

        r = r + 1
    End If
Next
End With





 Range("A13:F305").HorizontalAlignment = xlCenter
 Range("A1").Select

 End Sub

The marco that I have working can be seen here:

Sub InstrMacro()

Dim openPos As Integer
Dim closePos As Integer

Dim drwn, SheetNum
drwn = Range("E9") ' String to search in the sheet aka: the hot seat


'Performing a test to see if this is a new drawing or not
SheetNum = InStr(drwn, "^")

openPos = InStr(drwn, "s") 'True reguardless of the condition of the drawing

If SheetNum = 0 Then 'Assuming it is a new drawing
closePos = InStr(drwn, ".")
SheetNum = Mid(drwn, openPos + 1, closePos - openPos - 1)
Else

If SheetNum > 0 Then 'Assuming is NOT a new drawing
closePos = InStr(drwn, "^")
SheetNum = Mid(drwn, openPos + 1, closePos - openPos - 1)

End If
End If

Range("G20").Value = SheetNum


End Sub

A picture for this macro can be seen here.

I have tried making a separate macro the runs and can get the sheet number, but it seems that excel is just skipping this step and running through the rest of the program

I would like to put the drawing number in column B and the sheet number in sheet number in column c.

Answer 1

A solution with no loops nor regex

Sub FindIt()
    Dim strng As String, iPos As Long

    strng= "1sa2sb3s4sd5se"

    iPos = InStr(strng, "s")
    If iPos > 0 And iPos < Len(strng) Then
        If InStr("1234567890", Mid(strng, iPos + 1, 1)) > 0 Then
            MsgBox "Found s" & Mid(strng, iPos + 1,1) & " at position " & iPos
        End If
    End If
End Sub

Which can be easily twicked to limit the number of numeric digits following the “s” character

Answer 2

If it is s followed by a number/numbers, and this pattern only occurs once, you could use regex.

Option Explicit
Public Sub test()
    Dim re As Object, pattern As String, values(), i As Long
    values = Array("LC-94773s2^003735377.pdf", "LC-94773s2", "LC-93521s1-A^005241446")
    Set re = CreateObject("vbscript.regexp")
    pattern = "(s\d+)"
    For i = LBound(values) To UBound(values)
        Debug.Print Replace$(GetId(re, values(i), pattern), "s",vbNullString)
    Next
End Sub

Public Function GetId(ByVal re As Object, ByVal s As String, ByVal pattern As String) As String
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False '? True if case insensitive
        .pattern = pattern
        If .test(s) Then
            GetId = .Execute(s)(0).SubMatches(0)
        Else
            GetId = "No match"
        End If
    End With
End Function

---

You can vary this pattern, for example, if want start to be LC-9

Public Sub test()
    Dim re As Object, pattern As String, values(), i As Long
    values = Array("LC-94773s2^003735377.pdf", "LC-94773s2", "LC-93521s1-A^005241446")
    Set re = CreateObject("vbscript.regexp")
    pattern = "LC-9(.*)(s\d+)"
    For i = LBound(values) To UBound(values)
        Debug.Print Replace$(GetId(re, values(i), pattern), "s",vbNullString)
    Next
End Sub

Answer 3

To see if a string contains a lower case s followed by a numeral:

Sub sTest()
    Dim s As String, i As Long
    s = "jkuirelkjs6kbco82yhgjbc"

    For i = 0 To 9
        If InStr(s, "s" & CStr(i)) > 0 Then
            MsgBox "I found s" & i & " at position " & InStr(s, "s" & CStr(i))
            Exit Sub
        End If
    Next i

    MsgBox "pattern not found"
End Sub

Answer 4

You could try:

Option Explicit

Sub test()

    Dim arr As Variant
    Dim i As Long

    arr = Array("LC-94773s2^003735377.pdf", "LC-94773s2", "Mar", "LC-93521s1-A^005241446")

    For i = LBound(arr) To UBound(arr)
        If InStr(1, arr(i), "s") Then
            Debug.Print Mid(arr(i), InStr(1, arr(i), "s"), 2)
        End If
    Next i

End Sub