+ Reply to Thread
Results 1 to 2 of 2

VBA To Increment Sheets With The Same Name By 1

  1. #1
    Registered User
    Join Date
    05-16-2014
    MS-Off Ver
    Excel 2003
    Posts
    0

    VBA To Increment Sheets With The Same Name By 1

    I currently have a spreadsheet that parses a HL7 message string using "|" as a delimiter. The String that comes before the first "|" becomes the sheet name (Segment). The code executes on each line of the string (Each segment is parsed). The problem is that sometimes there are multiple segments with the same name. So instead of a new sheet being created, all segments are lumped into the same sheet with that name. What I am trying to do is have the code create a new sheet for each segment and if there it is already present, add sheet name with an incremented number.

    So given the sample message The MSH, SCH, PID, PV1 etc sheets are fixed. The DoHL7Parsing routine takes the line and parses it out in the existing sheet. The problem I'm having is lines that are the same such as AIP get lumped into one sheet. What I would like to happen is have AIP1,AIP2,AIP3,AIP4,AIP5 and AIP6. Each with the line parsed out. These are parsed by segment not fields. I want to be able to recognize the existing sheets and create new sheets if multiple segments with the same name are being parsed.

    Sample Message:
    MSH|^~\&|SR|500|CL|500|20140804150856-0500||SIU^S14|5009310|P|2.3|||AL|NE|USA
    SCH|10262|10262|""|S14^(SCHEDULED)^L|44950^APPENDECTOMY^C4||^^^201408081345-0500^^^^^^2||30|MIN^MINUTES|^^^201408081345-0500^201408081415-0500|10000000034^ROISTAFF^CHIEF^O||||||||
    PID|1|5000|50^^^USVHA&&0363^NI^FACILITY ID&500&L^^20140804~666^^^USSSA&&0363^SS^FACILITY ID&500&L~^^^USDOD&&0363^TIN^VA FACILITY ID&500&L~^^^USDOD&&0363^FI^FACILITY ID&500&L~736^^^USVHA&&0363^PI^VA FACILITY ID&500&L|736|DATA^PATIENT^^^^^L||19540214|M|||123 main Street^^SW RS^FL^33332^USA^P^^~^^^^^^N|||||||4221^764|666|||||N||||||N||
    PV1|1|I|||||||||||||||||||||||||||||||||||||500|
    OBX|1|CE|^SPECIALTY^||^GENERAL||||||S|||||
    OBX|2|CE|^PATIENT CLASS^||^INPATIENT^L||||||S|||||
    DG1|1|I9|540.1|ABSCESS OF APPENDIX||P
    DG1|2|I9||APPENDICITIS||PR
    RGS|1|A|
    AIS|1|A|44950^APPENDECTOMY^C4||||
    AIP|1|A|1000^PHYSICIAN^KT^|^SURGEON^99||||PENDING
    AIP|2|A|1000^NURSE^ONE^|^1ST ASST.^99||||PENDING
    AIP|3|A|1000^NURSE^TWO^|^2ND ASST.^99||||PENDING
    AIP|4|A|1000^ATTENDING^ONE^|^ATT. SURGEON^99||||PENDING
    AIP|5|A|115^DATA^PROVIDERONE^|^PRIN. ANES.^99||||PENDING
    AIP|6|A|1000^DATA^PATHOLOGIST^|^ANES. SUPER.^||||PENDING
    AIL||500^^^OR1|^OPERATING ROOM||||PENDING


    Current Code:

    Option Explicit

    Const HL7_DELIMITER_FIELD = "|"
    Const HL7_DELIMITER_SEGMENT = vbLf
    Sub DoHL7Parsing(sMessage As String)
    Dim vSegments As Variant, vCurSeg As Variant
    Dim vFields As Variant, rCurField As Range, iIter As Integer
    Dim wsSeg As Worksheet

    vSegments = VBA.Split(sMessage, HL7_DELIMITER_SEGMENT)

    For Each vCurSeg In vSegments
    vFields = VBA.Split(vCurSeg, HL7_DELIMITER_FIELD)
    If WorksheetExists(vFields(0), ThisWorkbook) Then
    On Error Resume Next
    For iIter = 1 To UBound(vFields)
    Set rCurField = ThisWorkbook.Worksheets(vFields(0)).Range("A65536").End(xlUp).Offset(1, 0)
    rCurField.Value = vFields(0)
    rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
    rCurField.Offset(0, 2).NumberFormat = "@"
    rCurField.Offset(0, 2).Value = vFields(iIter)
    Next iIter
    On Error Resume Next
    ElseIf Not WorksheetExists(vFields(0), ThisWorkbook) Then
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = vFields(0)
    For iIter = 1 To UBound(vFields)
    Set rCurField = ThisWorkbook.Worksheets(vFields(0)).Range("A65536").End(xlUp).Offset(1, 0)
    rCurField.Value = vFields(0)
    rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
    rCurField.Offset(0, 2).NumberFormat = "@"
    rCurField.Offset(0, 2).Value = vFields(iIter)
    Next iIter
    'MsgBox "Invalid or unkown segment: " & vFields(0)
    End If
    Next vCurSeg
    On Error Resume Next
    End Sub

    Public Function WorksheetExists(ByVal WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
    Dim Sht As Worksheet
    WorksheetExists = False

    If Not InWorkbook Is Nothing Then
    For Each Sht In InWorkbook.Worksheets
    If Sht.Name = WorksheetName Then WorksheetExists = True
    Next Sht
    Else
    For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name = WorksheetName Then WorksheetExists = True
    Next Sht
    End If
    On Error Resume Next
    End Function

    u9Grm.jpgJIRXO.jpg

  2. #2
    Forum Guru mikerickson's Avatar
    Join Date
    03-30-2007
    Location
    Davis CA
    MS-Off Ver
    Excel 2011
    Posts
    6,206

    Re: VBA To Increment Sheets With The Same Name By 1

    You might use something like this
    Please Login or Register  to view this content.
    _
    ...How to Cross-post politely...
    ..Wrap code by selecting the code and clicking the # or read this. Thank you.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. HELP - Referencing cells from different sheets using fixed increment
    By faisy110 in forum Excel Programming / VBA / Macros
    Replies: 8
    Last Post: 03-04-2014, 07:14 PM
  2. [SOLVED] Increment Sheets, but keep cell reference the same on drag
    By Alostsoul in forum Excel General
    Replies: 7
    Last Post: 02-28-2013, 04:38 AM
  3. [SOLVED] Control Button to increment by 1 and then select next cell in row to increment that cell
    By rammergu in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 09-19-2012, 07:35 PM
  4. Increment by 4
    By JPavao in forum Excel - New Users/Basics
    Replies: 1
    Last Post: 05-09-2007, 01:54 PM
  5. Increment/Increment letter in alphabetical order
    By Neil Goldwasser in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 01-25-2006, 05:10 AM

Tags for this Thread

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1