Excel CSI Keynote editor

Attribute VB_Name = "SaveAsTextRevitKeynotes" Function KeyFormatOK(Key As String, Optional NotStrict As Boolean) As Boolean Dim Re As RegExp Set Re = VBA.CreateObject("VBScript.RegExp") With Re If NotStrict Then .Pattern = "^(\d{2,5}[\-_\s]){0,1}((?:\d{2}[\-_\s\.]{0,1}){1,3}(?:\d{1,}){0,}){0,1}(.+)$" Else .Pattern = "^((?:\d{2}[\s]\d{2}[\s]\d{2}))(.+)$" ''Matches 00 00 00 * End If .IgnoreCase = True .MultiLine = True .Global = False End With Set Match = Re.Execute(Key) KeyFormatOK = Re.Test(Key) End Function ''reset revaliadtion in theis notebook and refresh pivot Sub ResetRevalidate() Dim NotesLastrow As Integer ''last row of notes Dim HeaderListAddr As String ''last used row NotesLastrow = SHTKeynotes.Cells(Rows.Count, 1).End(xlUp).row ''refresh headers With SHTHdrPivot.PivotTables("PrimaryHeaders") .PivotCache.Refresh With .PivotFields(1) .Orientation = xlRowField .Position = 1 .PivotItems("(blank)").Visible = False ''assign headers refernce ActiveWorkbook.Names("Divs").RefersTo = "='" & SHTHdrPivot.Name & "'!" & .DataRange.Cells.Address ''address of headers to use as divs name reference ''HeaderListAddr = "'" & SHTHdrPivot.Name & "'!" & .DataRange.Cells.Address ''address of headers to use as divs name reference End With End With ''ActiveWorkbook.Names("Divs").RefersTo = Trim(HeaderListAddr) With SHTKeynotes.Columns("C:C").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=Divs" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End Sub '''''''Primary Entry Point Sub FileExports() ' ' SaveAsText Macro ' If (MsgBox("This will overwrite the XLSX, XLSM, TXT (CSV)- continue?", vbInformation + vbOKCancel, "WARNING!")) <> vbOK Then MsgBox "Cancelled", vbOKOnly + vbInformation, "Cancelled" Exit Sub End If Select Case MsgBox("Sort and Deduplicate?", vbYesNoCancel, "De-Dupe") Case vbYes MsgBox "If no file save dialogs appear- re-publish without de-duplicating!", vbOKOnly On Error Resume Next DoSortColumnA DeDupeColumnA On Error GoTo 0 Case vbCancel MsgBox "Exiting, not sorted, saved, or de-duplicated", vbCritical Exit Sub Case Else End Select Dim FN Dim i FN = ThisWorkbook.FullName i = Len(FN) Do FN = Left(FN, i) i = i - 1 Loop While Right(FN, 1) <> "." And Len(FN) > 2 FN = Left(FN, i) TXT_FLAT_EXPORT (FN & ".TXT") 'ActiveWorkbook.SaveAs Filename:= _ ' FN & ".TXT" _ ' , FileFormat:=xlText, CreateBackup:=True ActiveWorkbook.SaveAs Filename:= _ FN & ".XLSX" _ , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=True, ReadOnlyRecommended:=True ActiveWorkbook.SaveAs Filename:= _ FN & ".XLSM" _ , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=True, ReadOnlyRecommended:=False MsgBox "Save complete", vbOKOnly + vbExclamation, "Saved XLSX, XLSM, TXT (CSV)" End Sub ''''''''''''''''''''''' Private Sub REFORMAT_DIVISIONS() ' ' Macro1 Macro ' Dim i Dim strRepl As String Dim strNew As String For i = 64 To 0 Step -1 strRepl = "Division " & Format(i, "0#") strNew = Format(i, "00") & " 00 00-DIVISION-" & Format(i, "00") Cells.Replace What:=strRepl, Replacement:=strNew, LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Next i End Sub Private Sub REFORM_NUMS() Dim i, j Dim XSTR As String Dim xx Dim ub As Integer Dim MinLen As Integer For i = 99 To 1 Step -1 ''For i = Sheet1.UsedRange.Rows.Count To 1 Step -1 ub = -1 XSTR = Sheet1.Cells(i, 1).Value xx = Split(XSTR, ".") On Error Resume Next: ub = UBound(xx): On Error GoTo 0 If ub > 0 Then XSTR = "" For j = 0 To ub If j > 2 Then MinLen = 3 Else MinLen = 2 ''FIRST 3 CHARACTERS 0,1,2, ARE PAIRS UNLESS LARGER. OTHERWISE 3 DIGITS UNLESS LARGER If MinLen < Len(xx(j)) Then MinLen = Len(xx(j)) XSTR = XSTR & Right("000000" & xx(j), MinLen) & "." Next j Do While Right(XSTR, 1) = "." And Len(XSTR) > 0 XSTR = Left(XSTR, Len(XSTR) - 1) Loop Cells(i, 1).Value = XSTR Range("c:c").Cells.Replace What:=Sheet1.Cells(i, 1).Value, Replacement:=XSTR, LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End If ''ub Next i End Sub '''- Sub DoSortColumnA() Dim x For x = 1 To 50 If SHTKeynotes.Columns(x).Hidden = True Then x = x - 1 Exit For End If Next x SHTKeynotes.Activate With SHTKeynotes.Sort.SortFields .Clear .Add Key:=SHTKeynotes.Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .Add Key:=SHTKeynotes.Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .Add Key:=SHTKeynotes.Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .Add Key:=SHTKeynotes.Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With With SHTKeynotes.Sort .SetRange SHTKeynotes.Range("A:" & Trim(Split(SHTKeynotes.Cells(1, x).AddressLocal, "$")(1))) .Header = xlNo '' xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub Sub DeDupeColumnA() ''dedupe For i = 1 To 2 Dim x As Range Set x = Sheet1.Range(Cells(Sheet1.Range("a1").End(xlDown).row, 3), Cells(1, 1)) x.Select x.RemoveDuplicates 1, xlNo Next i End Sub Private Sub test_TXT_FLAT_EXPORT() TXT_FLAT_EXPORT ("L:\0000-KEYS-CLASS-DIC\xxx_KEYNOTE_TEST_EXPORT.TXT") End Sub Sub TXT_FLAT_EXPORT(FN As String) Dim fso Dim irow As Integer Dim ws As Worksheet Dim Ftxt Set fso = CreateObject("Scripting.FileSystemObject") Set Ftxt = fso.CreateTextFile(FN, True) Set ws = Sheet1 Do irow = irow + 1 Ftxt.writeline (ws.Cells(irow, 1).Value & vbTab & ws.Cells(irow, 2).Value & vbTab & ws.Cells(irow, 3).Value & vbTab & vbTab & ws.Cells(irow, 4).Value) Loop While ws.Cells(irow + 1, 1) <> "" Ftxt.Close End Sub