20170601xlVBA Regular expression Extract medical data

Public Sub GetFirst () getdatafromword "first check" End subpublic Sub Getdatafromword (ByVal sheetname as String) AppSettings ' On Error GoTo errhandler Dim StartTime, usedtime as Variant StartTime = VBA. Timer ' Input code here Dim Wb as Workbook Dim Sht As Worksheet Dim Osht As Worksheet Dim Rng As Range Di M Arr as Variant Dim wdapp As Word.Application Dim wddoc As Word.Document Dim wdrng As Word.Range ' Const SHEET _name as String = "Extract Information" Set Wb = Application.thisworkbook Set Sht = Wb.worksheets (sheetname) Dim FilePath as Str ing with Application.filedialog (msofiledialogfilepicker). AllowMultiSelect = False. InitialFileName = Wb.path. Title = "Extract" & SheetName & "Data". Filters.clear. Filters.add "Word document", "*.rtf*" If. Show =-1 Then FilePath =. SelectedItems (1) Else MsgBox "You have not selected any folders, this rollup is interrupted!" "Exit Sub end If End With Debug.Print FilePath SET wdapp = New word.application Set wddoc = WdApp.Documents.Open (FilePath) Application.statusbar = ">>>> >>>>positioning & Replacing >>>>>>>> "Positioningclear Wddoc, 5 ' Locate remove English line avoid positive Then extract causes interference Application.statusbar = ">>>>>>>>regexpress Getting array >>>>>> >> "ARR = Reggetarray (WdDoc.Content.Text)" is in the array from full-text extract Wddoc.close False ' off Doc Wdapp.quit ' exit a PP Set wdapp = Nothing Set Wddoc = Nothing with Sht. Cells.clear. Range ("A1:d1"). Value = Array ("Large", "small", "D-Value", "e-value") Set Rng =. Range ("A2"). Resize (UBound (arr, 2), UBound (arr)) Rng.value = Application.WorksheetFunction.Transpose (arr) Sort2003. UsedRange End with usedtime = VBA. Timer-starttime Debug.Print "Usedtime:" & Format (Usedtime, "0.000 Seconds") ' MsgBox ' usedtime: ' & Format (U   Sedtime, "0.000 Seconds"), vbOKOnly, "Nextseven QQ" Errorexit: Set Wb = Nothing Set Sht = Nothing Set Rng = Nothing AppSettings False on Error Resume Next wdapp.quit Exit suberrhandler:if err.number <> 0 then MsgBox err.description & "! ", vbcritical," Nextseven QQ "Debug.Print err.description err.clear Resume errorexit End ifend Su        Bpublic Sub AppSettings (Optional isstart as Boolean = True) If Isstart then application.screenupdating = False Application.DisplayAlerts = False Application.calculation = xlcalculationmanual Application.statusbar = ">>>>>>>>macro is running>>>>>>>>" Else APPLICATION.SCREENUPDA Ting = True Application.DisplayAlerts = True application.calculation = xlcalculationautomatic Applica tion. StatusBar = False End ifend subfunction Reggetarray (ByVal Orgtext As String) as String () Dim Reg as Object, Mh as Ob Ject, Onemh As Object Dim Reg2 As Object Dim ARR () As String, Index as Long Dim Elm As String Set Reg = CreateObject ("VBScript.RegExp") Set Reg2 = Createobje CT ("vbscript.regexp") Reg2.global = True with Reg ' Orgtext = Application.ActiveDocument.Content. MultiLine = True. Global = True. Ignorecase = False ' available '. Pattern = "(?: \ s)? (\s*?)? \s? * "&" (?: []) ([^][^\r\n\v]*?) \s+? (d=[\d\.) +) \s+ (e=[\d\.) +) [\s]+?]. Pattern = "(?: \ S+?) ([A-calls;,,]*?)? \s? * "&" (?: []) ([^][^\r\n\v]*?) \s+? (d=[\d\.) +) \s+ (e=[\d\.)        +) [\s]+?] Set Mh =. Execute (orgtext) index = 0 ReDim Arr (1 to 4, 1 to 1) for each onemh in Mh Index = index + 1 ReDim Preserve ARR (1 to 4, 1 to Index) If onemh.submatches (0) <> "then Elm = ONEMH.SUBMATC Hes (0) Reg2.pattern = "[;,,]?            (Left View | front view | longitudinal section) +[;,,]? " Arr (1, index) = Reg2.replace (Elm, "") Reg2.pattern = "[\s#g]" arr (2, index) = Reg2.replace (onemh.sub MatcHes (1), "") ' Debug.Print onemh.submatches (2) ARR (3, Index) = Split (Onemh.submatches (2), "=") (1)    ' Debug.Print onemh.submatches (3) ARR (4, Index) = Split (Onemh.submatches (3), "=") (1) Next ONEMH End with Reggetarray = Arr set Reg = Nothing:set Mh = Nothing Set Reg2 = NothingEnd functionpublic Sub Position Ingclear (ByVal OpenDoc as Word.Document, ByVal times as Long) Dim wdrng As Word.Range Dim lngstart As Long Dim ln Gend as Long Dim lngtime as long for lngtime = 1 to times Lngend = OpenDoc.Content.End with opendoc.co Ntent. Find. ClearFormatting. Replacement.clearformatting. Text = "Alimentary SYSTEM". Replacement.text = "" If. Execute then Lngstart =. Parent.start Set wdrng = Opendoc.range (Lngstart, lngend) End If End With if not WD               Rng is Wdrng.find . ClearFormatting. Replacement.clearformatting. Text = "[^l^13][a-za-z0-9\-,;:.] @[^l^13] ". MatchWildcards = True. Wrap = Wdfindstop. Forward = True. Replacement.text = "^l" ' n = 0. Execute Replace:=wdreplaceall ' Do while. Execute ' n = n + 1 ' Debug.Print n; "____________"; .        Parent.text ' if n > "Exit do" Loop End With end If Set wdrng = Nothing Next lngtimeend subsub Sort2003 (ByVal rngwithtitle as Range, Optional sortcolumnno as Long = 1) ' Key 1 the keyword ' Order1 for the first sorted column indicates how the first field is sorted, the assignment is xlascending for ascending, and xldescending for descending. The header indicates whether the caption is included, the assignment is xlyes to indicate that the caption does not participate in the sort, the assignment is xlno for the title, the parameter sort ' matchcase is case-sensitive when sorting, and the assignment is false for case-insensitive ' orientation to indicate the sort direction, Assignment is xlTopToBottom or xlsortcolumns means sort by column, assignment to xlsortrows for ranking ' SortMethod is used to limit the sorting of Chinese characters, the assignment is xlpinyin to sort by pinyin, Assignment to Xlstroke means sort by stroke withRngwithtitle. Sort key1:=rngwithtitle.cells (1, Sortcolumnno), order1:=xlascending, Header:=xlyes, _ Matchcase:=false, Orien Tation:=xltoptobottom, Sortmethod:=xlpinyin End withend Sub

　　

20170601xlVBA Regular expression Extract medical data