首页
学习
活动
专区
工具
TVP
发布
社区首页 >问答首页 >引入文件,然后拆分字符串

引入文件,然后拆分字符串
EN

Stack Overflow用户
提问于 2019-04-08 04:38:39
回答 3查看 52关注 0票数 0

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

我已经可以获得图纸编号并将其放入B列。但是,我无法获得页码并将其放入C列。

文件名的示例包括:

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

其中的文件名将是:102-AG8APC1101-R25

代码语言:javascript
复制
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可以在这里看到:

代码语言:javascript
复制
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栏。

编辑2019/04/07:

我对Rawrplus有一个值得称赞的函数。但我不确定如何将其包含在我的主子模块中。有人能给我一些见解吗?谢谢!

代码语言:javascript
复制
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
EN

回答 3

Stack Overflow用户

发布于 2019-04-08 06:09:32

尝尝这个

代码语言:javascript
复制
Function GetShtNum(strng As String) As String
    GetShtNum = Split(Split(Split(strng, ".")(0), "s")(1), "^")(0)
End Function 
票数 0
EN

Stack Overflow用户

发布于 2019-04-08 07:27:26

此快速正则表达式用户定义函数将根据传入的可选参数检索图纸或图纸编号。

代码语言:javascript
复制
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

票数 0
EN

Stack Overflow用户

发布于 2019-04-08 08:18:40

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

要获得以下信息:

使用下面的代码(确保引用this post中看到的Microsoft Scripting Runtime ):

代码语言:javascript
复制
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
票数 0
EN
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接:

https://stackoverflow.com/questions/55563469

复制
相关文章

相似问题

领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档