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，然后在必须从文件字符串中提取日期时使用它。

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

然后在您的代码中，通过传递包含日期部分的字符串来使用此函数。

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

Answer 2

您可以使用此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)

无论如何只用宏来复制部分文件名到excel？

2 个答案: