VBA：在列中查找列標題和重新格式化（日期）值

Question

我有VBA代碼在excel文件中對數據執行一些操作，然後將所有數據轉換爲分號分隔的CSV /文本文件（代碼如下）。

現在，我想要的是在現有宏中添加VBA代碼以查找列標題（例如，「應用程序日期」），然後將所有日期轉換爲YYYY-MM-DD格式。此列中的原始值沒有固定的日期格式。

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 

我找不到任何老問題，實際上可以指向正確的方向。提前致謝。

UPDATE 1： 已經嘗試FORMAT（CellValue，「yyyy-mm-dd」）沒有成功。

更新2： 也試過在一個字符串變量讀取單元格的值，然後將其轉換回日期類型是這樣的：

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對我的耐心，儘管這沒什麼幫助。現在我的代碼如下所示：

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 

還有一個問題，這個宏，它無法處理日期前的1900年，Excel中的跛腳故意錯誤。我可能會在宏中找到一種方法，因爲VBA支持負數日期值，所以0100-1900之間的日期也被支持。

希望我的宏可以幫助別人。

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: 

如果你想搜索到列AA及以後，你需要第二個循環，並在連接字符串。 （例如：column = chr（64 + i）& chr（64 + j））