vbscript 五位数以上加逗号

untitled
Sub AddCommasToNumbers()
'UpdatebyExtendoffice20181106
Dim myrange As Range
Set myrange = Selection.Range

Do
    myrange.Select
    With Selection.Find
        .ClearFormatting
        .text = "[0-9]{5,}"
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True

        .Execute
        If Not .Found Then
            Exit Do
        End If
            Selection.text = Format$(Selection.text, "#,##0")

       
    End With
    Loop
End Sub

vbscript 笔记:获取最后一行

untitled
ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row


获取最后一列:
ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column


SpecialCells的方法,不能使用,因会得到空行。
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

参照:
https://blog.csdn.net/psp0001060/article/details/49643531	Excel VBA获取最后一行列 - 冬语的专栏 - CSDN博客

vbscript get_col_end

get_col_end
function get_col_end(rb,j1,optional sh1 = "")
	if sh1 = "" then sh1 = activesheet.name
    For i = 0 To 1000
        If sheets(sh1).Cells(rb + i, j1) <> sheets(sh1).cells(rb + i + 1, j1) Then
            re = rb + i
            Exit For
        End If
    Next
	get_col_end = re
end function

vbscript range_move

未测试

range_move
function range_move_inner(sh_ref,rb_ref,re_ref, _
sh_tgt,rb_tgt, _
optional clear1 = 0,_
optional cb = "a",optional ce = "n")
	range_move2 thisworkbook,sh_ref,rb_ref,re_ref,thisworkbook,sh_tgt,rb_tgt,clear1 ,cb ,ce
end sub

function range_move2(wb_ref,sh_ref,rb_ref,re_ref, _
wb_tgt,sh_tgt,rb_tgt, _
optional clear1 = 0, optional jmoved = "",_
optional cb = "a",optional ce = "n")
    if jmoved = "" then jmoved=ce
	arr_tmp = wb_ref.Sheets(sh_ref).Range(cb & rb_ref & ":" & ce & re_ref)
	wb_tgt.sheets(sh_tgt).Range(cb & rb_tgt & ":" & ce & (rb_tgt+re_ref-rb_ref)) = arr_tmp
	if clear1 = 1 then 
	    arr_tmp2 = make_arr_single_col("moved",re_ref-rb_ref+1)
	    wb_ref.Sheets(sh_ref).Range(jmove & rb_ref & ":" & jmove & re_ref) = arr_tmp2
	end if
end function

function range_move2_by_sh(sh_ref,rb_ref,re_ref, _
sh_tgt,rb_tgt, _
optional clear1 = 0,optional jmoved = "", _
optional cb = "a",optional ce = "n")
	arr_tmp = sh_ref.Range(cb & rb_ref & ":" & ce & re_ref)
	sh_tgt.Range(cb & rb_ref & ":" & ce & re_ref) = arr_tmp
	if clear1 = 1 then 
	    arr_tmp2 = make_arr_single_col("moved",re_ref-rb_ref+1)
	    sh_ref.Range(jmove & rb_ref & ":" & jmove & re_ref) = arr_tmp2
	end if
end function

vbscript 迭代相关

未测试

iteration
function iteration_fill_activesh(rb,jref,jtgt,d1, eu1,_
optional shref = "", optional shtgt = "")
	if shref = then shref = activesheet.name
	if shtgt = then shtgt = activesheet.name
	    '-----
    jref_s = convert1(jref)
    jtgt_s = convert1(jtgt)
	'--- get row_end
    re = Sheets(shref).Range(jref_s & rb & ":" & jref_s & eu1).Find(Cells(rb, jref), , , xlWhole, , xlPrevious).row
    '---
    str_fill = d1.Item(Cells(rb, jref).Value) '必要用.value,否则字典不识别
    If Str1 <> "" Then
        Dim arr1()
        ReDim arr1(1 To r_e - r_b + 1, 1 To 1)
        For ii = 1 To UBound(arr1)
            arr1(ii, 1) = str_fill
        Next
        Sheets(shtgt).Range(jtgt_s & rb & ":" & jtgt_s & re) = arr1
        'Debug.Print rb & " " & str_fill
    End If
    '---
    If Cells(re + 1, jref) <> "" Then
        fill_pjt1 re + 1, jref, j_tgt,  d1,eu1
    End If
end function



function Iteration_move()
	
end sub

vbscript selectAuthorRange

19.1.31
Sub selectAuthorRange()
    homePara
    Dim paraStart, authorEnd As Long
    paraStart = Selection.Start
    Do
        With Selection
            .MoveEndUntil ".;,"
            If FunctionGroup.spaceCount(Selection.text) < 3 Then
                .MoveRight wdCharacter, 3
            Else
                authorEnd = Selection.Start
                Exit Do
            End If
        End With
        
     
    Loop
    ActiveDocument.Range(paraStart, authorEnd - 2).Select
    
End Sub

vbscript getkeys SHM

getkeys
sub OnInitParameters()
    RegisterPushButton("action", "Action", 1)
end sub


sub OnExecAction(buttonId As Integer)
	Action()
end sub


'sub OnInit()
sub Action()
	dim scene_map , system_map , vizcommunication_map as array[string]
	scene.map.getkeys(scene_map)
	system.map.getkeys(system_map)
	vizcommunication.map.getkeys(vizcommunication_map)
	println("---------- scene_map ---------------------")	
	println(scene_map)
	println()
	println("---------- system_map ---------------------")
	println(system_map)
	println()
	println("---------- vizcommunication_map ---------------------")
	println(vizcommunication_map)
	println()
	println("---------- the end ---------------------")
	println("-------------------------------")
end sub

vbscript vba_word slct_sub

slct_sub
Sub slct_sub1()
    split1 = "---------------------------------------------*"
    strb_all = "--begin--"
    stre_all = "--end--"
    '----------
    il1 = Selection.Information(wdFirstCharacterLineNumber)
    ip1 = Selection.Information(wdActiveEndAdjustedPageNumber)
    '---get endup
    For i = 1 To 5000
        '---
        Selection.HomeKey unit:=wdLine
        Selection.EndKey unit:=wdLine, Extend:=wdExtend
        str_tmp = Selection.Text
        If str_tmp = strb_all Then End
        If str_tmp Like split1 Then
            up_l = Selection.Information(wdFirstCharacterLineNumber) + 1 '不包含分割行
            up_p = Selection.Information(wdActiveEndAdjustedPageNumber)
            Debug.Print up_p, up_l
            Exit For
        End If
        '---
        Selection.MoveUp unit:=wdLine, count:=1
    Next
    '---
    go1 ip1, il1
    '---get enddown
    For i = 1 To 5000
        '---
        Selection.HomeKey unit:=wdLine
        Selection.EndKey unit:=wdLine, Extend:=wdExtend
        str_tmp = Selection.Text
        If str_tmp = stre_all Then End
        If str_tmp Like split1 Then
            dn_l = Selection.Information(wdFirstCharacterLineNumber) - 1 '不包含分割行
            dn_p = Selection.Information(wdActiveEndAdjustedPageNumber)
            Debug.Print dn_p, dn_l
            Exit For
        End If
        '---
        Selection.MoveDown unit:=wdLine, count:=1
    Next
    '----------slct
    slct_cp1 up_p, up_l, dn_p, dn_l
End Sub

Function go1(p1, l1)
    Selection.GoTo wdGoToPage, , p1 'Selection.GoTo wdGoToLine, , l1 '只会跳到第一页
    Selection.MoveDown unit:=wdLine, count:=l1 - 1
End Function
Function slct_cp1(p1, l1, p2, l2, Optional cp = 0)
    go1 p1, l1
    a1 = Selection.Paragraphs(1).Range.Start
    go1 p2, l2
    a2 = Selection.Paragraphs(1).Range.End
    ActiveDocument.Range(a1, a2).Select
    '---
    If cp = 1 Then Selection.Copy
End Function

vbscript 从表格发送电子邮件

Send email from Form
Private Sub Command66_Click()
Const strParent = "\\prod.atonet.gov.au\atonetshares$\Individuals_Automation\Requests\Output\"

Dim olApp As Object
Dim objMail As Object
     Dim strID As String
     Dim strDate As String
     Dim strOfficer As String
     Dim strFolder As String
     Dim strRisk As String
     Dim strUserID As String
On Error Resume Next 'Keep going if there is an error

' Request
     strTitle = Me.Title
     strID = Me.ID
     strDate = Me.Request_Date
     strOfficer = Me.Officer
     strRisk = Me.Request_Risk
     strUserID = Me.Officer_UserID
     ' Full path
     strFolder = "<a href='" & strParent & strOfficer & "\" & strID & " - " & strRisk & " - " & strTitle & "'>Results</a>"
     strBody = "<html><body><p>Hi,</p><p>Please find at the link below the results of your data request.</p>" _
    & strFolder & "<p>Any queries please let me know.</p>Regards</body></html>"
    
Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open


If Err Then 'Outlook is not open
Set olApp = CreateObject("Outlook.Application") 'Create a new instance of Outlook
End If

'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)

With objMail
.Display
'Set body format to HTML
.BodyFormat = olFormatHTML
.To = strUserID
.Subject = strID & " " & strOfficer & " - " & strRisk & " - " & strTitle
.htmlBody = strBody & .htmlBody
.send

End With
'MsgBox "Results email has been sent"
End Sub

vbscript 芝加哥引用

Chicago ref citation
Sub chicagoRefTextCitation()
    Dim selecNum As Long
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .text = "\([0-9]{4}\)"
    .MatchWildcards = True
    .Forward = True
    .Wrap = wdFindStop
    Do
    .Execute
    If .Found Then

    selecNum = Selection.End
    
    
        With Selection
            .Collapse wdCollapseStart
            .MoveLeft wdWord, 3, wdExtend
            If InStr(.text, "et al") > 0 Then
                .MoveLeft wdWord, 1, wdExtend
                
                
            ElseIf InStr(.text, " and ") > 0 Then
               
            Else
                .Collapse wdCollapseEnd
                .MoveLeft wdWord, 1, wdExtend
                
            End If
            
        End With
        ActiveDocument.Range(Selection.Start, selecNum).Select
         Selection.Range.Style = ActiveDocument.Styles("_4_text_citation")
        
        Selection.MoveRight wdWord, 1
    Else
        Exit Do
    End If
    Loop
End With

End Sub