引入文件，然后拆分字符串
引入文件，然后拆分字符串
提问于 2019-04-08 04:38:39
我正在从文件夹中提取文件。根据这些文件并使用文件名，我尝试将图纸编号与图纸编号分开放在单独的列中。
我已经可以获得图纸编号并将其放入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栏。
编辑2019/04/07：
我对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回答 3
Stack Overflow用户
发布于 2019-04-08 06:09:32
尝尝这个
Function GetShtNum(strng As String) As String
GetShtNum = Split(Split(Split(strng, ".")(0), "s")(1), "^")(0)
End Function Stack Overflow用户
发布于 2019-04-08 07:27:26
此快速正则表达式用户定义函数将根据传入的可选参数检索图纸或图纸编号。
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
Stack Overflow用户
发布于 2019-04-08 08:18:40
我认为你把问题复杂化了。
要获得以下信息：
使用下面的代码(确保引用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页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/55563469
复制相关文章
相似问题
腾讯云开发者
