引入文件然后分解字符串答案

【问题标题】：Bring in files then breaking up the string引入文件然后分解字符串
【发布时间】：2019-04-08 08:18:40
【问题描述】：

我正在从文件夹中提取文件。从这些文件中并使用文件名，我试图将图纸编号与单独的列中的图纸编号分开。

我已经可以得到图纸编号并将其放入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

我工作的 marco 可以在这里看到：

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列的图纸编号中。

编辑 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

【问题讨论】：

"文件名"总是以s开头的字母吗？如果是的话，那就很简单了
附言。如果您添加对FileSystemObject 的引用，那么您可以使用智能感知访问File 下的所有方法。有关详细信息，请参阅this post。
在显示的示例中，哪个是工作表编号？

标签： excel vba

【解决方案1】：

这是根据您提供的示例数据假设的：

文件名总是以字母 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

返回想要的结果：

【讨论】：

事后看来，第二个for loop 作为Do Until 循环可能会更优雅，因为它可以避免使用GoTo，但是哦，好吧..
您想使用“Exit For”（即：如果 Mid(from, i, 1) = "^" 或 Mid(from, i, 1) = "." Then Exit For）和避免 GoTo 和标签本身
@DisplayName 啊对，忘了这是一回事。干杯，编辑
对不起，我缺乏智慧，但我试图将此功能合并到我的 Sub 中，但我认为我做得不对...您能否详细说明如何包含一个函数到我的潜艇？
@ChristopherLee 最简单的用途是声明一个变量并将函数结果存储到其中。 Dim result as String: result = getFileName(Range("B8"))

【解决方案2】：

试试这个

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

【讨论】：

【解决方案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

【讨论】：

【解决方案4】：

我认为你把问题复杂化了。

要得到这个：

使用下面的代码（确保引用Microsoft Scripting Runtime，如this post 所示）：

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

【讨论】：