【发布时间】：2011-06-27 12:10:14
【问题描述】：
此代码的目的是为 3 个不同的 MS Excel 文件格式化日期。每个文件都以不同的名称开头。一个是AT，另一个是PT，最后一个是MX。根据文件名中的前两个字符，日期的格式会有所不同。
例如：
当日期是这样的 PT 和 AT：20100710
我们使用这个公式：
=RIGHT(B38;2)&"."&MID(B38;5;2)&"."&LEFT(B38;4)
结果是：10.07.2010
当日期为 MX 时：1/1/2010
我们使用这个公式：
="0"&LEFT(B39;1)&"."&"0"&MID(B39;3;1)&"."&RIGHT(B39;4)
结果是：01.01.2010
然后我们使用 Excel 中的格式将其更改为：dd.mm.year
工作表称为“数据”，它是 Excel 文件中唯一的活动工作表。
代码目前什么都不做，没有错误等。它循环浏览文件夹中的工作表并保存它们。它不会改变“AT”或“PT”的日期。
Option Explicit
Public Sub FormatDates()
Dim wbOpen As Workbook
Dim strExtension As String
Const strPath As String = "H:\" 'Change Path to the folder you have your files in
'Comment out the 3 lines below to debug
' Application.ScreenUpdating = False
' Application.Calculation = xlCalculationManual
' On Error Resume Next
ChDir strPath
strExtension = Dir(strPath & "*.xls") 'change to xls if using pre 2007 excel
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
If Left(LCase(.Name), 2) = "pt" Or Left(LCase(.Name), 2) = "at" Then 'change to lower case and check start of name
ChangeAllDates ("NOT MX")
.Close SaveChanges:=True
ElseIf Left(LCase(.Name), 2) = "mx" Then
ChangeAllDates ("MX")
.Close SaveChanges:=True
Else
.Close SaveChanges:=False
End If
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Private Function ChangeAllDates(strType As String)
Dim strTemp As String
Dim strCellValue As String
Dim rng As Range
Dim cell As Range
Dim sht As Worksheet
Set sht = ActiveSheet
Sheets("data").Activate 'selects sheet named data
Set rng = Range("C2:C" & GetLastPopulatedCell(2, 2, sht)) 'finds last populated cell
On Error GoTo err_check
For Each cell In rng
strCellValue = CStr(cell.Value)
If Len(strCellValue) > 2 Then 'only check cells that have more than 2 charactors in them
If InStr(1, strCellValue, ".", vbTextCompare) = 0 Then
If strType = "MX" Then
strTemp = Left(strCellValue, 4) & "." & Mid(strCellValue, 5, 2) & "." & Right(strCellValue, 2)
Else
strTemp = Right(strCellValue, 2) & "." & Mid(strCellValue, 5, 2) & "." & Left(strCellValue, 2)
End If
If InStr(1, strCellValue, "/", vbTextCompare) > 0 Then 'change data / to .
strTemp = Replace(strCellValue, "/", ".", 1, , vbTextCompare)
'now check to make sure that it reads yyyy.mm.dd if not then we need to reverse it and check
'it has 2 numbers for month and year
strTemp = CheckDataFormat(strTemp)
End If
Else
strTemp = strCellValue
End If
cell.Value = strTemp 'replace the cell value with the formatted value
strCellValue = ""
strTemp = ""
End If
Next cell
On Error GoTo 0
Exit Function
err_check:
MsgBox Error.Name & vbCrLf & "Error happend on cell " & cell.Address
End Function
Private Function GetLastPopulatedCell(lgRow As Long, lgCol As Long, sht As Worksheet) As Long
Dim i As Integer
Dim s As String
For i = 0 To 10000 'set a default number of cells to check in this case I have set it to 10,000
If sht.Cells(lgRow, lgCol).Value <> "" Then
lgRow = lgRow + 1
Else
GetLastPopulatedCell = lgRow - 1
Exit For
End If
Next i
End Function
Private Function CheckDataFormat(str As String) As String
Dim strR As String
Dim i As Integer
Dim vArray As Variant
'str = "06.01.2011"
'have to check if date is in d.m.yyyy format if so we need to change it to dd.mm.yyyy
If Len(str) < 10 Then 'only care if less than 10 charators
vArray = Split(str, ".") 'split into array on points
str = ""
For i = 0 To UBound(vArray)
If Len(vArray(i)) = 1 Then 'if only 1 charactor long we know we are missing 0
str = str & "0" & vArray(i) & "." 'check if 0 exists before number if not add it
Else
str = str & vArray(i) & "."
End If
Next i
'remove last dot on the end
If Right(str, 1) = "." Then str = Left(str, Len(str) - 1)
End If
Debug.Print str
'strR = Right(str, 5)
'If Left(strR, 1) = "." Then
' str = Right(str, 4) & "." & Left(str, (Len(str) - 5)) 'move the year to the front
' str = Left(str, 5) & Right(str, 2) & Mid(str, 5, 3) 'switch round month and day
' Debug.Print str
'End If
CheckDataFormat = str
End Function
【问题讨论】：
-
@user787601：请将您的代码格式化为
code，否则阅读起来很痛苦！谢谢。这次我为你做了。 -
你的问题是什么？？
-
哦，是的，问题是什么？您是否尝试过在调试器模式下单步执行您的代码？
-
谢谢Jean-Francois...没有错误消息，所以单步执行它并没有太大帮助，也许看到传递是好的...我希望它能够工作，但是正确现在除了循环浏览和保存文档之外什么都没有发生。
-
感觉您是在寻求调试咨询服务，而不是诚实的问题...正如其他人指出的那样，逐步找出问题所在非常简单。当我看到很多 cmets 时更是如此。