Question

我目前有一个电子表格，使用＆＃34; |＆＃34;解析HL7消息字符串。作为分隔符。在第一个＆＃34; |＆＃34;之前出现的字符串成为工作表名称（细分）。代码在字符串的每一行上执行（每个段都被解析）。问题是有时会有多个具有相同名称的段。因此，不是创建新工作表，而是将所有段集中到具有该名称的同一工作表中。我要做的是让代码为每个段创建一个新工作表，如果它已经存在，添加一个增加数字的工作表名称。

示例消息：

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


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

enter image description here

Answer 1

这里的诀窍是只计算Left(ShtName,3)值等于vFields(0)的工作表数量。根据计数，添加1并追加到vField(0)的末尾。使用这种方法，您甚至不需要脏On Error Resume Next，因为您不会将同一张纸定位两次，这会大大降低您的行数。

对于纸张计数，请将以下功能添加到模块中：

Function CountSheetsWithName(ShtName As String) As Long

    Dim WS As Worksheet, Res As Long
    Res = 0
    For Each WS In ThisWorkbook.Worksheets
        If Left(WS.Name, 3) = ShtName Then
            Res = Res + 1
        End If
    Next

    CountSheetsWithName = Res

End Function

更新您的DoHL7Parsing子程序，如下所示：

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, sShtName As String

    vSegments = VBA.Split(sMessage, HL7_DELIMITER_SEGMENT)

    Application.ScreenUpdating = False

    For Each vCurSeg In vSegments
        vFields = VBA.Split(vCurSeg, HL7_DELIMITER_FIELD)
        For iIter = 1 To UBound(vFields)
            sShtName = vFields(0) & (CountSheetsWithName(CStr(vFields(0))) + 1) ' Append the count + 1 to end of name.
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = sShtName
            Set rCurField = ThisWorkbook.Worksheets(sShtName).Range("A" & Rows.Count).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
    Next vCurSeg

    Application.ScreenUpdating = True

End Sub

<强>结果：

enter image description here

希望这有帮助。

VBA使用相同名称增加表格1

1 个答案: