Copying xlsx hard-coded data to an excel sheet

kp
kp used Ask the Experts™
on
I have got  an additional  requirement to save hard-coded data from excel sheet (Input.xlsx) (attached)   to a  excel sheet (in sheet 2 of output-23-10.xlsx) being  generated out of  below vbscript (Toxls.vbs) .

Looking to add  new functionality in  an existing utility vbscript (Toxls.vbs)  to achieve  copying hard-coded data from excel (Input.xlsx) to a  excel sheet (sheet2 of output-23-10.xlsx )   being generated from below vbscript  vbscript (Toxls.vbs) .  

Toxls.vbs :- Used to convert Pipe Delimited text into an excel sheet (Output.xlsx).


' 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\user\Desktop\Input.txt")
strOutputFile = objFSO.GetAbsolutePathname("C:\Users\user\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.Workbooks.Add
Set objSheet = objExcel.ActiveWorkbook.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
objExcel.ActiveWorkbook.SaveAs strOutputFile, cExcel7
objExcel.ActiveWorkbook.Close False
objExcel.Quit


output-23-10.xlsx  (sheet1) and Toxls.vbs script  is attached for reference .
Input.xlsx
output-23-10.xlsx
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
Does this work for you?

' 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!"

Open in new window

kpconsultant

Author

Commented:
Thanks a lot for your help ! Your solution  and timeliness is much appreciated.
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
You're welcome!

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