VBA Excel 加载项：将列格式从常规更改为自定义日期的代码

Question

我的数据提供商在我获取的.XLSX文件中更改了几个内容。我添加了一个新的子程序，根据此应用程序所期望的模型修复数据：

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有一个标题行“Processed Date”，H2单元格及其以下单元格存储为通用格式，如11/15/2016。我需要将所有日期更改为自定义日期格式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“有点有效”。 它的效果是复制文本，“14-Oct-2016”，每个行都有列H（除了第一行）。 这是最少可接受的。

我真正需要的是一条语句，它将获取H列所有行的文本，并将存储的值从显示为10/14/2016更改为14-Oct-2016等。 仅更改格式不足够。 我需要更改存储的值。 我不知道如何做到这一点。

- John Adams

---

请参阅如何避免在Excel VBA宏中使用Select。 - user4039065

Answer 1

您只在H列的最后一个有值的单元格上操作。请将范围从H2延伸到最后一个单元格，以设置所有单元格的格式。

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

- user4039065

---

谢谢。我用你的代码替换了上面的尝试，并运行了整个新的插件。列H中单元格的值仍然与以前相同（即典型值显示为11/22/2016）。但是，当我单击列H中的一个单元格并选择“格式化单元格”时，格式确实已从常规更改为自定义和dd-mmm-yyyy。是否需要另一个语句来实际“应用”新格式到单元格值，以便它显示为22-Nov-2016？ - John Adams

看起来你的日期并不是真正的日期，只是看起来像日期的文本。选择该列并使用“数据”、“文本对列”，在第三个屏幕上选择正确的MDY格式。此外，在导入新数据时，也需要执行此操作。 - user4039065

谢谢。请看我上面对原帖进行的编辑。你的答案很有帮助。 - John Adams

请看我上面的编辑。我仍需要您的帮助。 - John Adams

Answer 2

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

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()函数以转换文本格式。如果有帮助，请告诉我。

- ThomasMX

---

谢谢。尝试了您的建议后出现了编译错误。所以我在For循环前面添加了：Dim i as Integer，然后是dim currentCell as Object。然后我得到了错误代码6溢出。 - John Adams

Answer 3

刚刚解决了你遇到的同样问题。我也测试了你的情况，关键是使用TextToColumns命令。尝试一下这个代码：

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

- Wayne

Answer 4

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

- KST

---

你能给你的回答提供更多的上下文吗？另外，请格式化你的代码。 - Eliot K