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

我找不到任何可以指向正确方向的旧问题。提前谢谢。

更新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的蹩脚故意bug。我可能会在宏中找到一种方法，因为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）＆amp; chr（64 + j））

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

2 个答案: