error in below code
Option Explicit
Dim inputFilePath As String
Dim layoutFilePath As String
Dim formattedFile As String
Dim layoutFile As String
Sub main()
Dim starposArray() As Integer
Dim endposArray() As Integer
Dim lengthArray() As Integer
Dim noOfFields As Integer
Dim i As Integer
Dim outrow As Integer
Dim substrg As String
inputFilePath = SelectFile("input")
If inputFilePath = "N" Then
Exit Sub
End If
layoutFilePath = SelectFile("layout")
If layoutFilePath = "N" Then
Exit Sub
End If
If bIsWorkbookOpen(layoutFilePath) Then
MsgBox "File is open!!!"
Workbooks(layoutFilePath).Close
End If
Workbooks.Open FileName:=layoutFilePath
layoutFile = ActiveWorkbook.Name
Workbooks.Add
Range("A1") = "Field Name"
Range("A2") = "Length"
Dim temp As String
temp = FilePath(inputFilePath) & FileNameNoExt(inputFilePath) & "_Formatted.xlsx"
If bIsWorkbookOpen(temp) Then
MsgBox "File is open!!!"
Workbooks(temp).Close
End If
On Error Resume Next
ActiveWorkbook.SaveAs (temp)
If Err.Number = 1004 Then
Dim fdl As FileDialog
Set fdl = Application.FileDialog(msoFileDialogSaveAs)
fdl.Title = "Save the formatted file As"
If fdl.Show = False Then
MsgBox "Process Ended By User!!"
ActiveWorkbook.Close savechanges:=False
Workbooks(layoutFile).Close
Exit Sub
End If
temp = fdl.SelectedItems(1)
ActiveWorkbook.SaveAs (temp)
End If
formattedFile = ActiveWorkbook.Name
Windows(layoutFile).Activate
Range("A2:B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows(formattedFile).Activate
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
Range("A3") = "Start Pos"
Range("A4") = "End Pos"
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
noOfFields = Selection.Columns.Count
ReDim starposArray(noOfFields)
ReDim endposArray(noOfFields)
ReDim lengthArray(noOfFields)
starposArray(0) = 1
endposArray(0) = Range("B2")
lengthArray(0) = Range("B2")
Range("B3") = starposArray(0)
Range("B4") = endposArray(0)
For i = 1 To noOfFields - 1
starposArray(i) = endposArray(i - 1) + 1
endposArray(i) = endposArray(i - 1) + Cells(2, i + 2)
lengthArray(i) = Cells(2, i + 2)
Cells(3, i + 2) = starposArray(i)
Cells(4, i + 2) = endposArray(i)
Next
Dim objFileSystem, objInputFile
Dim strInputFile, inputData, strData
Const OPEN_FILE_FOR_READING = 1
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objInputFile = objFileSystem.OpenTextFile(inputFilePath, OPEN_FILE_FOR_READING)
' read everything in an array
inputData = Split(objInputFile.ReadAll, vbNewLine)
outrow = 5
For Each strData In inputData
i = 1
For i = 1 To noOfFields
substrg = Mid(strData, starposArray(i - 1), lengthArray(i - 1))
Cells(outrow, i + 1) = "'" & substrg
Next
outrow = outrow + 1
Next
objInputFile.Close
Set objFileSystem = Nothing
Range("B1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
Selection.Font.Name = "Courier New"
Range("A1:A4").Select
Range(Selection, Selection.End(xlToRight)).Interior.Color = RGB(144, 177, 250)
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWindow.Zoom = 90
Range("A1").Select
ActiveWorkbook.Save
Workbooks(layoutFile).Close
MsgBox "Process Completed Successfully!"
End Sub
Function FilePath(strPath As String) As String
FilePath = Left$(strPath, InStrRev(strPath, "\"))
End Function
Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
Function SelectFile(fileType As String)
Dim fdl As FileDialog
'Dim FileName As String
Dim FileChosen As Integer
Set fdl = Application.FileDialog(msoFileDialogFilePicker)
'Set the caption of the dialog box,
fdl.Title = "Please Select a " & fileType & " File"
If fileType = "input" Then
'Set the InitialFile Path
'fdl.InitialFileName = "c:\"
'Set the Folder View
fdl.InitialView = msoFileDialogViewSmallIcons
'Set the filter
fdl.Filters.Clear
fdl.Filters.Add "Text files", "*.txt"
Else
fdl.Filters.Clear
fdl.Filters.Add "Excel files", "*.xls, *.xlsx"
End If
FileChosen = fdl.Show
If FileChosen <> -1 Then
'Not choosen anything / Clicked on CANCEL
'MsgBox "You have choosen nothing!"
SelectFile = "N"
Else
'display name and complete path of file chosen
'MsgBox fdl.SelectedItems(1)
SelectFile = fdl.SelectedItems(1)
End If
Set fdl = Nothing
End Function
Function bIsWorkbookOpen(wbName As String)
Dim wkb As Workbook
'Dim bIsWorkbookOpen As Boolean
On Error Resume Next
Set wkb = Workbooks(wbName)
If Not wkb Is Nothing Then
bIsWorkbookOpen = True
End If
End Function
Option Explicit
Dim inputFilePath As String
Dim layoutFilePath As String
Dim formattedFile As String
Dim layoutFile As String
Sub main()
Dim starposArray() As Integer
Dim endposArray() As Integer
Dim lengthArray() As Integer
Dim noOfFields As Integer
Dim i As Integer
Dim outrow As Integer
Dim substrg As String
inputFilePath = SelectFile("input")
If inputFilePath = "N" Then
Exit Sub
End If
layoutFilePath = SelectFile("layout")
If layoutFilePath = "N" Then
Exit Sub
End If
If bIsWorkbookOpen(layoutFilePath) Then
MsgBox "File is open!!!"
Workbooks(layoutFilePath).Close
End If
Workbooks.Open FileName:=layoutFilePath
layoutFile = ActiveWorkbook.Name
Workbooks.Add
Range("A1") = "Field Name"
Range("A2") = "Length"
Dim temp As String
temp = FilePath(inputFilePath) & FileNameNoExt(inputFilePath) & "_Formatted.xlsx"
If bIsWorkbookOpen(temp) Then
MsgBox "File is open!!!"
Workbooks(temp).Close
End If
On Error Resume Next
ActiveWorkbook.SaveAs (temp)
If Err.Number = 1004 Then
Dim fdl As FileDialog
Set fdl = Application.FileDialog(msoFileDialogSaveAs)
fdl.Title = "Save the formatted file As"
If fdl.Show = False Then
MsgBox "Process Ended By User!!"
ActiveWorkbook.Close savechanges:=False
Workbooks(layoutFile).Close
Exit Sub
End If
temp = fdl.SelectedItems(1)
ActiveWorkbook.SaveAs (temp)
End If
formattedFile = ActiveWorkbook.Name
Windows(layoutFile).Activate
Range("A2:B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows(formattedFile).Activate
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
Range("A3") = "Start Pos"
Range("A4") = "End Pos"
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
noOfFields = Selection.Columns.Count
ReDim starposArray(noOfFields)
ReDim endposArray(noOfFields)
ReDim lengthArray(noOfFields)
starposArray(0) = 1
endposArray(0) = Range("B2")
lengthArray(0) = Range("B2")
Range("B3") = starposArray(0)
Range("B4") = endposArray(0)
For i = 1 To noOfFields - 1
starposArray(i) = endposArray(i - 1) + 1
endposArray(i) = endposArray(i - 1) + Cells(2, i + 2)
lengthArray(i) = Cells(2, i + 2)
Cells(3, i + 2) = starposArray(i)
Cells(4, i + 2) = endposArray(i)
Next
Dim objFileSystem, objInputFile
Dim strInputFile, inputData, strData
Const OPEN_FILE_FOR_READING = 1
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objInputFile = objFileSystem.OpenTextFile(inputFilePath, OPEN_FILE_FOR_READING)
' read everything in an array
inputData = Split(objInputFile.ReadAll, vbNewLine)
outrow = 5
For Each strData In inputData
i = 1
For i = 1 To noOfFields
substrg = Mid(strData, starposArray(i - 1), lengthArray(i - 1))
Cells(outrow, i + 1) = "'" & substrg
Next
outrow = outrow + 1
Next
objInputFile.Close
Set objFileSystem = Nothing
Range("B1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
Selection.Font.Name = "Courier New"
Range("A1:A4").Select
Range(Selection, Selection.End(xlToRight)).Interior.Color = RGB(144, 177, 250)
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWindow.Zoom = 90
Range("A1").Select
ActiveWorkbook.Save
Workbooks(layoutFile).Close
MsgBox "Process Completed Successfully!"
End Sub
Function FilePath(strPath As String) As String
FilePath = Left$(strPath, InStrRev(strPath, "\"))
End Function
Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
Function SelectFile(fileType As String)
Dim fdl As FileDialog
'Dim FileName As String
Dim FileChosen As Integer
Set fdl = Application.FileDialog(msoFileDialogFilePicker)
'Set the caption of the dialog box,
fdl.Title = "Please Select a " & fileType & " File"
If fileType = "input" Then
'Set the InitialFile Path
'fdl.InitialFileName = "c:\"
'Set the Folder View
fdl.InitialView = msoFileDialogViewSmallIcons
'Set the filter
fdl.Filters.Clear
fdl.Filters.Add "Text files", "*.txt"
Else
fdl.Filters.Clear
fdl.Filters.Add "Excel files", "*.xls, *.xlsx"
End If
FileChosen = fdl.Show
If FileChosen <> -1 Then
'Not choosen anything / Clicked on CANCEL
'MsgBox "You have choosen nothing!"
SelectFile = "N"
Else
'display name and complete path of file chosen
'MsgBox fdl.SelectedItems(1)
SelectFile = fdl.SelectedItems(1)
End If
Set fdl = Nothing
End Function
Function bIsWorkbookOpen(wbName As String)
Dim wkb As Workbook
'Dim bIsWorkbookOpen As Boolean
On Error Resume Next
Set wkb = Workbooks(wbName)
If Not wkb Is Nothing Then
bIsWorkbookOpen = True
End If
End Function