Принесите файлы и разбейте строку

Question

Я вытягиваю файлы из папки.Из этих файлов и используя имена файлов, я пытаюсь отделить номер чертежа от номера листа в отдельных столбцах.

Я уже могу получить номер чертежа и поместить его в столбец B. Однако я не могу получитьномер листа и поместите его в столбец C.

Примеры имен файлов:

• LC-94399s102-AG.dwg
• LC-91994s8A.DWG
• MC-94997sPC1 ^ 004441182.dwg
• LC-94399s101-R.dwg
• LC-94399s25 ^ 003687250.dwg

Из этихимена файлов будут: 102-AG, 8A, PC1, 101-R, 25,

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 просто пропускает этот шаг и проходит через остальную часть программы

Я хотел бы поставить номер чертежа в столбце Bd номер листа в номере листа в столбце c.

Edit 04/07/2019:

У меня есть функция слава Rawrplus.Но я не уверен, как включить это в мою основную сабвуфер.Может ли кто-нибудь дать мне какие-либо идеи?Спасибо!

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

        '-----------------------------------------------------------
        Call getFileName(drwn)

        '------------------------------------------------------------

        r = r + 1
        End If
Next
End With

Answer 1

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

Чтобы получить это:

Используйте код ниже (убедитесь, что вы ссылаетесь на Microsoft Scripting Runtime, как видно из в этом посте ):

Public Sub GetDrawingInfo()

    Dim fso As New FileSystemObject

    'Find the folder where the drawings exist
    Dim fld As Folder
    Set fld = fso.GetFolder(ThisWorkbook.Sheets("Header Info").Range("D11") & _
                                            "\Design\Substation\CADD\Working\COMM\")

    ' Set the target cells to fill the table. Mine started at D12
    Dim target As Range
    Set target = Range("D12")

    Dim f As File
    ' this will tell us what row we are in
    Dim count As Long
    count = 0 
    For Each f In fld.Files
        If LCase(fso.GetExtensionName(f.Name)) = "dwg" Then
            ' We found a .dwg file
            count = count + 1
            ' write filename in first column
            target.Cells(count, 1).Value = f.Name
            ' Get filename without extension
            Dim fname As String
            fname = fso.GetBaseName(f.Name)
            ' Split the filename at the "s"
            Dim parts() As String
            parts = Strings.Split(fname, "s", , vbTextCompare)
            ' The fist part is the code? Like LC-94399
            target.Cells(count, 2).Value = parts(0)
            ' Split the second part at the "^"
            parts = Strings.Split(parts(1), "^", , vbTextCompare)
            ' The first part is the drawing number
            ' Set drawing number as text
            target.Cells(count, 3).NumberFormat = "@"
            target.Cells(count, 3).Value = parts(0)
            ' If a second part exists, it is the sheet number
            If UBound(parts) = 1 Then
                target.Cells(count, 4).Value = parts(1)
            End If
        End If
    Next

End Sub

Answer 2

Попробуйте это

Function GetShtNum(strng As String) As String
    GetShtNum = Split(Split(Split(strng, ".")(0), "s")(1), "^")(0)
End Function 

Answer 3

Эта пользовательская функция быстрого регулярного выражения извлекает либо чертеж, либо номер листа в зависимости от переданного в него необязательного аргумента.

Option Explicit

Function stripPieces(str As String, Optional pc As Integer = 1)

    Static rgx As Object

    stripPieces = CVErr(xlErrNA)

    If Right(LCase(str), 4) <> ".dwg" Then Exit Function

    If rgx Is Nothing Then Set rgx = CreateObject("VBScript.RegExp")

    With rgx
        .IgnoreCase = False
        Select Case pc
          Case 1
            .Pattern = "[A-Z]{2}\-[0-9]{5}s"
            If .Test(str) Then
                str = .Execute(str).Item(0)
                stripPieces = Left(str, Len(str) - 1)
            End If
          Case 2
            .Pattern = "s[A-Z0-9\-]{2,9}"
            If .Test(str) Then
                str = .Execute(str).Item(0)
                stripPieces = Mid(str, 2)
            End If
          Case Else
            stripPieces = CVErr(xlErrValue)
        End Select
    End With

End Function

'use on worksheet like
=stripPieces($E2, 1)    'for dwg
=stripPieces($E2, 2)    'for sheet

Answer 4

Предполагается, что из приведенных вами примеров данных:

• Имя файла всегда предшествует буква s

• и всегда сопровождается либо . , либо ^

  Private Function getFileName(ByVal from As String)
  
  Dim i As Integer
  Dim pos As Integer
  Dim temp As String
  
  For i = Len(from) To 1 Step -1
      If Mid(from, i, 1) = "s" Then ' first we find rightmost "s"
          pos = i
      End If
  Next i
  
  For i = pos + 1 To Len(from)
      If Mid(from, i, 1) = "^" Or Mid(from, i, 1) = "." Then
          Exit For
      End If
      temp = temp + Mid(from, i, 1)
  Next i
  
      getFileName = temp
  
  End Function
  

Возвращает желаемый результат: