Учитывая строку, я хочу извлечь некоторый текст

Question

Учитывая список строк, я хочу разделить строки на разные столбцы.Строки не всегда имеют одинаковый формат, поэтому я не могу использовать один и тот же подход каждый раз.Я пытаюсь поместить LC-XXXXXX в столбец B, затем удалить «s» и поместить текст после «s» и между «^» или «.»(независимо от того, что строка содержит) в столбец C

Я запускаю «цикл for» для каждой строки, в которой сохраняется как массив и выглядит примерно так:

Я использовал разделение, обрезать и промежуточные команды, но безуспешно.

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

Я хотел бы взять список строк и поместить LC-XXXXX в столбец B и номер листа (числа между "s" и "^" или иногда ".dwg" или ".pdf") в столбце C

NEW EDIT 04/06/2019

Новое редактирование 04/07/2019

Основной код 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

Марко, которое яРаботать можно увидеть здесь:

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

Изображение для этого макроса можно увидеть здесь.

Я пыталсясоздание отдельного макроса запускается и может получить номер листа, но кажется, что Excel просто пропускает этот шаг и запускает остальную часть программы

Я хотел бы указать номер чертежа в столбце B и номер листа в номере листа в столбце c.

Answer 1

Решение без циклов и регулярных выражений

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

, которое можно легко изменить, чтобы ограничить количество числовых знаков после символа «s»

Answer 2

Чтобы узнать, содержит ли строка нижний регистр s , за которым следует цифра:

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 3

Вы можете попробовать:

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

Answer 4

Если после s идет число / число, и этот шаблон встречается только один раз, вы можете использовать регулярное выражение.

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

---

Вы можете изменить этот шаблон, например, если хотите начатьбыть 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