VBA：在列中查找列标题和重新格式化（date）值

我有VBA代码来执行Excel数据文件中的一些操作，然后将所有的数据转换成分号分隔CSV /文本文件（代码如下）。

现在，我只想在现有macros中添加VBA代码来查找列标题（例如，“应用程序date”），然后将所有date转换为YYYY-MM-DD格式。 此列中的原始值没有固定的date格式。

Public Sub ExportToCsvFile(FName As String, _ Sep As String, SelectionOnly As Boolean, _ AppendDataOnExistingFile As Boolean) Dim WholeLine As String Dim FNum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim FirstRow As Long Dim LastRow As Long Dim FirstCol As Integer Dim LastCol As Integer Dim CellValue As String Application.ScreenUpdating = False On Error GoTo EndMacro: FNum = FreeFile If SelectionOnly = True Then With Selection FirstRow = .Cells(1).Row FirstCol = .Cells(1).Column LastRow = .Cells(.Cells.Count).Row LastCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange FirstRow = .Cells(1).Row FirstCol = .Cells(1).Column LastRow = .Cells(.Cells.Count).Row LastCol = .Cells(.Cells.Count).Column End With End If If AppendDataOnExistingFile = True Then Open FName For Append Access Write As #FNum Else Open FName For Output Access Write As #FNum End If For RowNdx = FirstRow To LastRow WholeLine = "" For ColNdx = FirstCol To LastCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = Chr(34) & Chr(34) Else CellValue = Cells(RowNdx, ColNdx).Value CellValue = Replace(Replace(CellValue, Chr(150), Chr(45)), Chr(151), Chr(45)) CellValue = Replace(Replace(CellValue, Chr(60), Chr(60) & Chr(32)), Chr(10), "<br />") CellValue = Chr(34) & Replace(CellValue, Chr(34), Chr(34) & Chr(34)) & Chr(34) End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #FNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #FNum End Sub Sub ExportToSemiColonCsv() Dim FileName As Variant Dim Sep As String FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="CSV Files (*.csv),*.csv") If FileName = False Then Exit Sub End If ExportToCsvFile FName:=CStr(FileName), Sep:=";", _ SelectionOnly:=False, AppendDataOnExistingFile:=True End Sub 

我找不到任何能够让我朝着正确的方向发展的老问题。 提前致谢。

更新1：已经尝试格式（CellValue，“yyyy-mm-dd”）没有成功。

更新2：也尝试读取stringvariables中的单元格值，然后将其转换回datetypes，如下所示：

 If IsDate(CellValue) Then Dim str1 As String str1 = Cells(RowNdx, ColNdx).Value Dim DateValue As Date DateValue = CDate(str1) CellValue = Format(DateValue, "yyyy-mm-dd") End If 

没有用，实际上，它似乎代码不执行（虽然没有编译错误）。

更新3：最后，我能够使用.NumberFormat和.Text解决它。 请参阅下面的答案，了解最终的代码和限制。

Answer 1

那么，最后，我能够使用NumberFormat和.Text解决问题。 感谢@Ed Heywood-Lonsdale对我的耐心，尽pipe没有什么帮助。 现在我的代码如下所示：

 Public Sub ExportToCsvFile(FName As String, _ Sep As String, SelectionOnly As Boolean, _ AppendDataOnExistingFile As Boolean) Dim WholeLine As String Dim FNum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim FirstRow As Long Dim LastRow As Long Dim FirstCol As Integer Dim LastCol As Integer Dim CellValue As String Application.ScreenUpdating = False On Error GoTo EndMacro: FNum = FreeFile If SelectionOnly = True Then With Selection FirstRow = .Cells(1).Row FirstCol = .Cells(1).Column LastRow = .Cells(.Cells.Count).Row LastCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange FirstRow = .Cells(1).Row FirstCol = .Cells(1).Column LastRow = .Cells(.Cells.Count).Row LastCol = .Cells(.Cells.Count).Column End With End If If AppendDataOnExistingFile = True Then Open FName For Append Access Write As #FNum Else Open FName For Output Access Write As #FNum End If For RowNdx = FirstRow To LastRow WholeLine = "" For ColNdx = FirstCol To LastCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = Chr(34) & Chr(34) Else CellValue = Cells(RowNdx, ColNdx).Value If IsDate(CellValue) Then Cells(RowNdx, ColNdx).NumberFormat = "yyyy-mm-dd" CellValue = Cells(RowNdx, ColNdx).Text End If CellValue = Replace(Replace(CellValue, Chr(150), Chr(45)), Chr(151), Chr(45)) CellValue = Replace(Replace(CellValue, Chr(60), Chr(60) & Chr(32)), Chr(10), "<br />") CellValue = Chr(34) & Replace(CellValue, Chr(34), Chr(34) & Chr(34)) & Chr(34) End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #FNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #FNum End Sub Sub ExportToSemiColonCsv() Dim FileName As Variant Dim Sep As String FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="CSV Files (*.csv),*.csv") If FileName = False Then Exit Sub End If ExportToCsvFile FName:=CStr(FileName), Sep:=";", _ SelectionOnly:=False, AppendDataOnExistingFile:=True End Sub 

这个macros还有一个问题，它无法处理1900年以前的date，这是excel的蹩脚故意错误。 我可能会在macros中find一种方法，因为VBA支持负数date值，所以0100-1900之间的date也被支持。

希望我的macros可以帮助别人。

Answer 2

也许像…

 Next RowNdx for i = 0 to 25 column = chr(64 + i) header = Range(column & "1") if header = "Application Data" then columns(column).EntireColumn.NumberFormat = "yyyy-mm-dd;@" msgbox "Column " & column & "Has been formatted" end if next EndMacro: 

如果你想search列AA和更多，你需要第二个循环，并连接string。 （例如，列= chr（64 + i）＆chr（64 + j））