VBA Excel 插件：将列格式从一般日期更改为自定义日期的代码

Question

我的数据提供者更改了我获得的 .XLSX 文件中的几处内容。我添加了一个新的 sub 来根据此应用程序期望的模型修复数据：

Sub Feb27FixModel()
    ActiveSheet.Range("H2").End(xlDown).NumberFormat = "dd-mmm-yyyy"            'change format of Processed Date
    Dim colNum As Integer
    colNum = ActiveSheet.Rows(1).Find(what:="Legacy code", lookat:=xlWhole).Column
    ' Done twice to insert 2 new cols
    ActiveSheet.Columns(colNum + 1).Insert
    ActiveSheet.Columns(colNum + 1).Insert
    ' New col headings
    ActiveSheet.Cells(1, colNum + 1).Value = "Origin Code"
    ActiveSheet.Cells(1, colNum + 2).Value = "Jurisdiction Code"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "County Name"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "State Abbreviation"
    ActiveWorkbook.Save
End Sub

除了上面第一行的结果之外，一切正常。在活动工作表中，H 列的标题行值为“已处理日期”，H2 单元格及其下方的单元格存储为“常规”，其值类似于 2016 年 11 月 15 日。我需要将所有日期更改为 dd-mmm-yyyy 的自定义日期。以下语句无法为我完成此操作：

ActiveSheet.Range("H2").End(xlDown).NumberFormat = "dd-mmm-yyyy"

编辑（2017 年 3 月 1 日）：

感谢下面@Jeeped 的回答，我添加了另一个语句，这是解决方案的代码：

With ActiveSheet
    .Range(.Cells(2, "H"), .Cells(.Rows.Count, "H").End(xlUp)).NumberFormat = "dd-mmm-yyyy"
    .Range(.Cells(2, "H"), .Cells(.Rows.Count, "H").End(xlUp)).Value = ActiveCell.Text
End With

编辑（2017 年 3 月 2 日）：

我昨天犯了一个错误。在调试中，我必须在断点处在工作表中选择了一个好的单元格；因此，引用 ActiveCell.Text “有点工作”。它的效果是在 H 列的每一行（第一行除外）中将文本复制为“2016 年 10 月 14 日”。这是最低限度可以接受的。

我真正需要的是一个语句，它将获取 H 列所有行的文本并将存储的值从显示为 10/14/2016 更改为 14-Oct-2016 等。仅更改是不够的要自定义的格式。我也需要更改存储的值。我不知道该怎么做。

Answer 1

Sub Letsgive_try1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    

    'paste your path here
    MyPath = "C:\Users\ThakareK\Documents\Box Support Files\Voice Acq\"

    'Just for safer side if you forget to add \
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'to check all excel files in you files folder directory
    FilesInPath = Dir(MyPath & "*.csv*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with name test you can change as per yours below
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        ActiveWorkbook.SaveAs Filename:="Test.xlsx"
    rnum = 1

    'Main part starts here Loop through all files in the array(myFiles)
    'if you want to change data format add your range of cell and give date fomrat of your need
    
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            mybook.Activate
            
            
            'this part copies dynamic data
            Range("A1").Select
            Range(Selection, Selection.End(xlDown)).Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
            
          
            'this part pastes data in new excel we genertaed
            Windows("TEST.xlsx").Activate
           
            With Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(0)
           .PasteSpecial Paste:=xlPasteColumnWidths
           .PasteSpecial Paste:=xlPasteValues
            End With
            
            
            'if you want to change data format add your range of cell instead of(G:G) and give date fomrat of your need
            With ActiveSheet.Range("G:G")
           .NumberFormat = "mm-dd-yyyy"
           .TextToColumns
            End With
            
            mybook.Close savechanges:=False
            
            On Error GoTo 0

               

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Answer 2

刚刚解决了您遇到的相同问题。也测试了你的案例。关键是 TextToColumns 命令。使用您的代码，试一试：

With ActiveSheet.Range("H:H")
    .NumberFormat = "dd-mmm-yyyy"
    .TextToColumns
End With

Answer 3

这个四行循环应该可以解决问题。测试了它。 ;)

For i = 2 To Columns("H").End(xlDown).Row 'from row nr 2 to the rownr of last cell of column H
    Set currentCell = Cells(i, "h")
    currentCell.Value = Format(currentCell.Value, "dd-mm-yyyy")
Next i

它遍历每个单元格并对其应用Format() 函数以转换文本格式。让我知道这是否有帮助。

Answer 4

您只对 H 列中具有值的最后一个单元格进行操作。从 H2 到最后一个单元格以设置所有单元格的格式。

with ActiveSheet
    .Range(.cells(2, "H"), .cells(.rows.count, "H").End(xlUp)).NumberFormat = "dd-mmm-yyyy"
end with