record splitter

Atul

New member
Joined
Nov 5, 2013
Messages
6
Reaction score
0
Points
0
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 TU4RFilePath As String
Dim expectedAFfilePath As String
Dim reportFile As String
Dim layoutFile As String
Dim mainworkbook As String

Sub SC01ValidationMain()

TU4RFilePath = SelectFile("TU4R")
If TU4RFilePath = "N" Then
Exit Sub
End If

expectedAFfilePath = SelectFile("Expected AF")
If expectedAFfilePath = "N" Then
Exit Sub
End If

Workbooks.Add
Dim temp As String
temp = FilePath(TU4RFilePath) & FileNameNoExt(TU4RFilePath) & "_ValidationReport.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
Exit Sub
End If
temp = fdl.SelectedItems(1)
ActiveWorkbook.SaveAs (temp)
End If
reportFile = ActiveWorkbook.Name
Range("A1") = "Record No."
Range("B1") = "Validation Status"
Range("C1") = "SC01 Segment"
Range("D1") = "AF1"
Range("E1") = "AF2"
Range("F1") = "AF3"
Range("A1").Select
Dim objFileSystem, objInputFile, objAFFile
Dim strInputFile, inputData, strData, sc01str, sc01pos, recordno, AFstrData
Dim sc01strpos, model, j, AFinputData, Result, i, k
Dim AF(3) As String
Const OPEN_FILE_FOR_READING = 1
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objInputFile = objFileSystem.openTextFile(TU4RFilePath, OPEN_FILE_FOR_READING)
Set objAFFile = objFileSystem.openTextFile(expectedAFfilePath, OPEN_FILE_FOR_READING)
' read everything in an array
inputData = Split(objInputFile.readall, vbNewLine)
AFinputData = objAFFile.readall
recordno = 1
For Each strData In inputData
sc01strpos = InStr(1, strData, "SC01")
sc01str = Mid(strData, sc01strpos, 32)
model = Mid(sc01str, 21, 3)
If model = "V40" Then
k = 4
Windows(reportFile).Activate
Cells(recordno + 1, 1) = "Record#" & recordno
j = 24
Result = "Passed"
For i = 1 To 3
AF(i) = Mid(sc01str, j, 3)
j = j + 3
Windows(reportFile).Activate
If AF(i) = " " Then
Cells(recordno + 1, k) = AF(i)
k = k + 1
Else
If InStr(1, AFinputData, AF(i)) > 0 Then
Cells(recordno + 1, k) = AF(i)
k = k + 1
'GoTo done:
Else
Cells(recordno + 1, k) = AF(i)
Cells(recordno + 1, k).Interior.Color = RGB(254, 0, 0)
k = k + 1
Result = "Failed"
End If
End If
'done:
Next
Cells(recordno + 1, 2) = Result
Cells(recordno + 1, 3) = sc01str
Else
Windows(reportFile).Activate
Cells(recordno + 1, 1) = "Record#" & recordno
Cells(recordno + 1, 2) = "Record Not Validated"
Cells(recordno + 1, 3) = sc01str
End If
recordno = recordno + 1
sc01strpos = 0
sc01str = ""
model = ""

Next
objInputFile.Close
Set objFileSystem = Nothing
Windows(reportFile).Activate
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
Selection.Font.Name = "Courier New"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Name = "Calibri"
Selection.Interior.Color = RGB(144, 177, 250)
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWindow.Zoom = 90
Range("A1").Select
ActiveWorkbook.Save
MsgBox "Process Completed Successfully!"

End Sub
Function SelectFile(fileType As String)
Dim fdl As FileDialog
Dim FileChosen As Integer
Set fdl = Application.FileDialog(msoFileDialogFilePicker)
'Set the caption of the dialog box,
fdl.Title = "Please Select a " & fileType & " File"
'Set the Folder View
fdl.InitialView = msoFileDialogViewSmallIcons
'Set the filter
fdl.Filters.Clear
fdl.Filters.Add "Text files", "*.txt"
FileChosen = fdl.Show
If FileChosen <> -1 Then
SelectFile = "N"
Else
SelectFile = fdl.SelectedItems(1)
End If
Set fdl = Nothing
End Function
Function bIsWorkbookOpen(wbName As String)
Dim wkb As Workbook
On Error Resume Next
Set wkb = Workbooks(wbName)
If Not wkb Is Nothing Then
bIsWorkbookOpen = True
End If
End Function
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
 
Thanks! This has helped me a lot!!!
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call RemoveToolBar
End Sub

Private Sub Workbook_Open()
Call CreateToolBar
End Sub

Sub CreateToolBar()
Dim cBar As CommandBar
Dim cControl As CommandBarControl
Call RemoveToolBar
'Create toolbar
Set cBar = Application.CommandBars.Add
cBar.Name = "MainframeFileReader"
cBar.Visible = True
'Add a control
Set cControl = cBar.Controls.Add
With cControl
.Caption = "Excel File-Aid"
.Style = msoButtonCaption
.OnAction = "FileReaderMain"
.TooltipText = "Click to start file reader"
End With
End Sub

Sub RemoveToolBar()
On Error Resume Next
Application.CommandBars("MainframeFileReader").Delete
End Sub
 
Private Sub Create_Dash_Board_Click()
Dim strUserID As String
Dim strPassword As String
Dim strDomain As String
Dim strProject As String
Dim QCConnection

'Set QCConnection = CreateObject("TDApiOle80.TDConnection")

strUserID = InputBox(Prompt:="Please enter your user ID.", Title:="ENTER YOUR USERID")
strPassword = InputBox(Prompt:="Please enter your Password.", Title:="ENTER YOUR PASSWORD")
If strUserID = vbNullString Or strPassword = vbNullString Then
MsgBox ("Connection to QC could not be established because User ID or Password is not entered")
Exit Sub


Else
QCConnection.InitConnectionEx "===========QC LINK==============="

QCConnection.Login strUserID, strPassword

If (QCConnection.LoggedIn <> True) Then
MsgBox "QC User Authentication Failed"
End
End If

strDomain = CStr(Sheet1.Cells(3, 3))
strProject = CStr(Sheet1.Cells(4, 3))

QCConnection.Connect strDomain, strProject

If (QCConnection.AuthenticationToken = "") Then
MsgBox "QC Project Failed to Connect to " & strProject
QCConnection.Disconnect
End
End If


Set TstFactory = QCConnection.TestFactory
End If
End Sub
 
Private Sub CommandButton1_Click()
Dim i As Long
Dim IE As Object
Dim objElement As Object
Dim objCollection As Object
Set IE = CreateObject("InternetExplorer.Application")

IE.Visible = True

If Sheet2.Cells(5, 10) = "Google" Then

IE.Navigate "http://www.Google.com/"

Else
IE.Navigate "http://www.wikipedia.Org/"
End If

Application.StatusBar = "Please wait kara...website load hot aahe"

Do While IE.Busy
Application.Wait DateAdd("s", 1, Now)
Loop

End Sub
 
Back
Top