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
Comments
Post a Comment