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

我正在工作的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

Answer 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

返回所需结果：

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

我认为您已经使问题复杂化了。

要获取此信息：

使用下面的代码（确保您引用this post中的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

引入文件，然后分解字符串

4 个答案: