无论如何，只有部分的文件名复制到macros与macros？

我已经看到了一些与这个问题有关的post，但是提供的答案根本无法帮助我。 例如，我的文件名是“SPC_PLTB_450B_05092017_25°C_CW”，我如何只复制文件名中的date并使用macros将其粘贴到我的主工作簿中？ 我的macros将find列C中的下一个空单元格，并粘贴文件名的date。

这是我现在的macros。 我在哪里可以插入所需的代码？ 先谢谢你。 分试（）

Dim wb As Workbook, wb2 As Workbook, wb3 As Workbook Dim ws As Worksheet Dim fn As String Set wb = ActiveWorkbook 'this is for the excel to add one more worksheet for the raw data Set ws = Sheets.Add(After:=Sheets(Worksheets.Count)) Dim Ret 'this whole part is for importing the raw data files into excel Ret = Application.GetOpenFilename("Lkl Files (*.lkl), *.lkl") If Ret <> False Then With ActiveSheet.QueryTables.Add(Connection:= _ "TEXT;" & Ret, Destination:=Range("$A$1")) .Name = "SPC_PLTB_450B_12092107_25°C_CW" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 65001 .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) .TextFileDecimalSeparator = "," .TextFileThousandsSeparator = "." .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With End If Sheets(2).Activate 'this is to search for the next empty cell and put the date Dim FirstCell As String Dim i As Integer FirstCell = "C19" Range(FirstCell).Select Do Until ActiveCell.Value = "" If ActiveCell.Value = "" Then Exit Do Else ActiveCell.Offset(1, 0).Select End If Loop ActiveCell = Format(Date, "mm/dd/yyyy") 'this is to filter the raw data into the desired value ws.Activate ws.AutoFilterMode = False 'change the value of Criteria1 between "" into the desired value for filtering ws.Range("$A$9:$P$417").AutoFilter Field:=5, Criteria1:= _ "1" Range("F31:F401").Select Selection.Copy Sheets(2).Activate 'this is for the raw data to be copied into each worksheet FirstCell = "D19" Range(FirstCell).Select Do Until ActiveCell.Value = "" If ActiveCell.Value = "" Then Exit Do Else ActiveCell.Offset(1, 0).Select End If Loop Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Sheets(3).Activate FirstCell = "C19" Range(FirstCell).Select Do Until ActiveCell.Value = "" If ActiveCell.Value = "" Then Exit Do Else ActiveCell.Offset(1, 0).Select End If Loop ActiveCell = Format(Date, "mm/dd/yyyy") ws.Activate Range("D31:D401").Select Application.CutCopyMode = False Selection.Copy Sheets(3).Activate FirstCell = "D19" Range(FirstCell).Select Do Until ActiveCell.Value = "" If ActiveCell.Value = "" Then Exit Do Else ActiveCell.Offset(1, 0).Select End If Loop Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Sheets(4).Activate FirstCell = "C19" Range(FirstCell).Select Do Until ActiveCell.Value = "" If ActiveCell.Value = "" Then Exit Do Else ActiveCell.Offset(1, 0).Select End If Loop ActiveCell = Format(Date, "mm/dd/yyyy") ws.Activate Range("G31:G401").Select Application.CutCopyMode = False Selection.Copy Sheets(4).Activate FirstCell = "D19" Range(FirstCell).Select Do Until ActiveCell.Value = "" If ActiveCell.Value = "" Then Exit Do Else ActiveCell.Offset(1, 0).Select End If Loop Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True With ActiveWorkbook .Worksheets(.Worksheets.Count).Delete End With End Sub 

Answer 1

您可以使用此UDF从文件名中提取8位数字的date部分。 我编辑了代码以date格式返回date。

  Function datepart(filename As Variant) As Date Dim i As Long Dim s As String For i = 1 To Len(filename) If Mid(filename, i, 8) Like "########" Then s = Mid(filename, i, 8) datepart = DateSerial(Right(s, 4), Mid(s, 3, 2), Left(s, 2)) Exit For End If Next End Function 

为了将它写入列A中的下一个空单元格中，您可以编写类似这样的内容

  ActiveCell = datepart(ret) 

Answer 2

您可以在标准模块上使用此UDF，然后在必须从文件string中提取date时使用它。

 Function GetFileDate(ByVal fName As String) As Date Dim RE As Object, Matches As Object Set RE = CreateObject("VBScript.RegExp") With RE .Global = False .Pattern = "\d{8}" End With If RE.test(fName) Then Set Matches = RE.Execute(fName) GetFileDate = Format(Matches(0), "00-00-0000") End If End Function 

然后在你的代码中，通过传递包含date部分的string来使用这个函数。

 ActiveCell.Value = GetFileDate(ws.QueryTables(1).Name)