1

我有 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： 最后，我可以使用.NumberFormatand来解决它.Text。有关最终代码和限制，请参见下面的答案。

4

2 回答 2

1

好吧，最后，我能够使用NumberFormatand解决问题.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 之间的日期。

希望我上面的宏可以帮助某人。

于 2013-07-01T06:37:18.533 回答
0

Maybe something like...

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:

If you want to search into columns AA and beyond, you need a second loop and to concatenate the strings. (eg column = chr(64+i) & chr(64+j))

于 2013-06-28T08:21:17.320 回答