vba - 无论如何，仅使用宏将部分文件名复制到 Excel 中？

Question

我看过一些与此问题相关的帖子，但提供的答案根本无法帮助我。例如，我的文件名是“SPC_PLTB_450B_05092017_25°C_CW”，我如何使用宏仅复制文件名中的日期并将其粘贴到我的主工作簿中？我的宏将在 C 列中找到下一个空单元格，并将文件名的日期粘贴到其中。

这是我现在拥有的宏。我可以在哪里插入所需的代码？先感谢您。 子试验()

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 位日期部分。我已编辑代码以以日期格式返回日期。

   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)