vbscript code (.VBS)  changes Date format of one of the date column (Date)  from to [b][u]"mm/dd/yyyy"  to "dd/mm/y" when saved to excel

kp
kp used Ask the Experts™
on
Below vbscript code (.VBS)  changes Date format of one of the date column (Date)  from to "mm/dd/yyyy"  to "dd/mm/yyyy" . when saved to Excel.


Row Number|Row Action|Department|Date
123456          |Insert          |Airlines         |05/12/2016
3456              |Update       |Engineering |10/31/2014
234234         |Insert          |Arts                |2015
452435         |Insert          |Design           |2016


' Define constants
Const cExcel7 = 51
Const xlContinuous = 1
Const xlEdgeBottom = 9
Const xlEdgeLeft = 7
Const xlEdgeRight = 10
Const xlEdgeTop = 8

' Create file system object
Set objFSO = CreateObject("Scripting.FilesystemObject")

' Files to work woth
strInputFile = objFSO.GetAbsolutePathname("C:\Users\sktneer\Desktop\Input.txt")
strInputExcelFile = objFSO.GetAbsolutePathname("C:\Users\sktneer\Desktop\Input.xlsx")
strOutputFile = objFSO.GetAbsolutePathname("C:\Users\sktneer\Desktop\output-23-10.xlsx")

' Read text file into array
With objFSO.OpenTextFile(strInputFile, 1)
    arrInput = Split(.ReadAll, vbNewLine)
End With

' Start Excel, create a new worksheet
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objexcel.Application.SheetsInNewWorkbook = 3
Set dwb = objExcel.Workbooks.Add
Set objSheet = dwb.Worksheets(1)

' Initialize row index
intRow = 0

' Process each line of input file
For Each strInput in arrInput

    ' Skip all blank lines
    If strInput <> "" Then
        ' Start a new row in Excel, start at first column
        intRow = intRow + 1
        intCol = 0

        ' Parse input text line
        arrTokens = Split(strInput, "|")

        ' Add each value to Excel sheet
        For Each strToken In arrTokens
            intCol = intCol + 1
            With objSheet.Cells(intRow, intCol)
                .Value = Trim(strToken)

                ' Bold first row
                If intRow = 1 Then
                    .Font.Bold = True
                End If

                ' Borders on all cells
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
           
            End With


    Next
   End If
Next

' Write file and close Excel
objExcel.DisplayAlerts = False
dwb.SaveAs strOutputFile, cExcel7

'Setting Sheet2 in strOutFile as destination sheet to hold the data from Sheet1 in Input.xlsx File
Set objSheet = objExcel.ActiveWorkbook.Worksheets(2)

'*********************************
'Copying the data from Input.xlsx
'*********************************

Set swb=objexcel.Workbooks.Open(strInputExcelFile)
Set sws=swb.Worksheets(1)

sws.range("A1").currentregion.copy objsheet.range("A1")

swb.Close False
dwb.Close True
objExcel.Quit
MsgBox "Task completed!"
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
ste5anSenior Developer

Commented:
Please use Excel's From Text instead of manually importing the data. Just specify the pipe as column terminator. E.g.

Const cExcel7 = 51
Const xlContinuous = 1
Const xlEdgeBottom = 9
Const xlEdgeLeft = 7
Const xlEdgeRight = 10
Const xlEdgeTop = 8

Set objFSO = CreateObject("Scripting.FilesystemObject")
strInputFile = objFSO.GetAbsolutePathname("C:\Users\sktneer\Desktop\Input.txt")
strInputExcelFile = objFSO.GetAbsolutePathname("C:\Users\sktneer\Desktop\Input.xlsx")
strOutputFile = objFSO.GetAbsolutePathname("C:\Users\sktneer\Desktop\output-23-10.xlsx")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objexcel.Application.SheetsInNewWorkbook = 3
Set dwb = objExcel.Workbooks.Add
Set objSheet = dwb.Worksheets(1)
With objSheet.QueryTables.Add(Connection:="TEXT;" & strInputFile, Destination:=Range("$A$1"))
    .CommandType = 0
    .Name = "test"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 850
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileOtherDelimiter = "|"
    .TextFileColumnDataTypes = Array(1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With

objExcel.DisplayAlerts = False
dwb.SaveAs strOutputFile, cExcel7
Set objSheet = objExcel.ActiveWorkbook.Worksheets(2)
Set swb=objexcel.Workbooks.Open(strInputExcelFile)
Set sws=swb.Worksheets(1)
sws.range("A1").currentregion.copy objsheet.range("A1")
swb.Close False
dwb.Close True
objExcel.Quit
MsgBox "Task completed!"

Open in new window


p.s. please embed code into [code] tags (the CODE button in the toolbar). You can edit your post.
Bill PrewTest your restores, not your backups...
Top Expert 2016

Commented:
Can't you just change the format of that column in the Excel file???


»bp
Fabrice LambertConsulting
Distinguished Expert 2017

Commented:
Hi,

Just provide the NumberFormat property:
sws.range("A1").currentregion.copy objsheet.range("A1")
objsheet.Range("D:D").NumberFormat = "dd/mm/yyyy"

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial