Results 1 to 7 of 7

Thread: record splitter

  1. #1

    record splitter



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    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

  3. #3
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    683
    Articles
    0
    Excel Version
    Excel 2010 64bit

  4. #4
    Thanks! This has helped me a lot!!!

  5. #5
    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

  6. #6
    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

  7. #7
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •