vbscript,Code片段,代码实例,代码示例,代码片段库

vbscript VBA - 基本（local_db）连接

VBA - 基本（local_db）连接

gistfile1.vb

Public Sub simpleVBAdb()

    Dim stsql As String
    Dim stDb As String
    Dim cnt As ADODB.Connection: Set cnt = New ADODB.Connection
    Dim rst1 As ADODB.Recordset: Set rst1 = New ADODB.Recordset

    stConn = "Provider=SQLOLEDB;Data Source=(local);" & _
                  "Initial Catalog=plrec;" & _
                  "Integrated Security=SSPI;"

    stsql = "SELECT * FROM billingFrequency"

    With cnt
        If .State = 0 Then
            .Open (stConn)
            .CursorLocation = adUseClient
        End If
    End With
    
    With rst1
        .Open stsql, cnt
        Set .ActiveConnection = Nothing
    End With
  
    rst1.Close
    Set rst1 = Nothing
    
    cnt.Close
    Set cnt = Nothing

End Sub

vbscript 根据特定列中的数据为Excel行设置交替背景（在此示例中：cloumn 2（B））

根据特定列中的数据为Excel行设置交替背景（在此示例中：cloumn 2（B））

alternating_background.vbs

Sub Faerbe_RGB()
'Makro von PauleVBA @ gutefrage.net
Dim lngGrau As Long  'RGB-Wert fuer Grau
Dim lngWeiss As Long 'RGB-Wert für weiss
Dim lngEnde As Long 'Ende der gefuellten Zeilen
Dim lngInterneFarbe As Long 'die gewuenschte Fuellung
Dim I As Long ' einfach Zaehlvariable

lngGrau = RGB(235, 235, 235) 'Farbe Grau definieren
lngWeiss = RGB(255, 255, 255) 'Farbe weiss definieren
lngEnde = Range("B:B").SpecialCells(xlCellTypeLastCell).Row
lngInterneFarbe = lngWeiss ' festsetzen, welche Farbe die Ueberschrift hat
     ' die andere Farbe wird dann automatisch für die erste Zeile genommen

For I = 2 To lngEnde 'von Zeile 5 bis zur letzten genutzten
    If Cells(I, 2) <> Cells(I - 1, 2) Then 'Zellinhalte vergleichen
        'Farbwechsel
        If lngInterneFarbe = lngGrau Then
            'wenn bisher Grau, dann weiss
            lngInterneFarbe = lngWeiss
        Else
            'wenn bisher weiss, dann grau
            lngInterneFarbe = lngGrau
        End If
    End If
    'die Zeile faerben
    Rows(I).Interior.Color = lngInterneFarbe
Next I
End Sub

vbscript 自定义函数根据条件连接到或多个字符串。

自定义函数根据条件连接到或多个字符串。

CONCATIF.vbs

Public Function CONCATIF(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
Rem CONCATIF(Site!$G$1:$G$9000,H2,Site!$AE$1:$AE$9000,", ",TRUE)
Dim i As Long, j As Long
    
    With compareRange.Parent
        Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
    End With
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(CONCATIF, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    CONCATIF = CONCATIF & Delimiter & CStr(stringsRange.Cells(i, j))
                End If
            End If
        Next j
    Next i
CONCATIF = Mid(CONCATIF, Len(Delimiter) + 1)
End Function

vbscript VB脚本（http://www.kanaya440.com/contents/tips/vbs/008.html）ーートカットを作成する

VB脚本（http://www.kanaya440.com/contents/tips/vbs/008.html）ーートカットを作成する

createShortcut.vbs

Option Explicit

Dim WSH,sc

Set WSH=CreateObject("WScript.Shell")

Set sc = WSH.CreateShortcut("C:\Documents and Settings\xxxx\デスクトップ\メモ帳.lnk")
sc.TargetPath = "C:\WINDOWS\notepad.exe"
sc.save

Set sc = Nothing
Set WSH = nothing

vbscript 使用CDO寄信，但不知为何会寄不出去。

使用CDO寄信，但不知为何会寄不出去。

sendmail_via_cdo.vbs

' http://www.rgagnon.com/wshdetails/wsh-0018.html
' http://www.rgagnon.com/wshdetails/wsh-0002.html
' http://www.bernhard-ehlers.de/projects/OutlookSecurity.html

' Get full filepath from 1st argument
Dim Full_Filename
Dim Filename
Set objArgs = WScript.Arguments
if WScript.Arguments.Count=0 then
  WScript.Quit 1
end if
' WScript.Echo objArgs(0)
Full_Filename = objArgs(0)

' Parse to simple filename
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(Full_Filename)
Filename = objFSO.GetFileName(objFile)
Set objFile = Nothing
Set objFSO = Nothing

' Start to mail
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = Filename
objMessage.From = "your_name@your_domain.com.tw"
objMessage.To = "your_name@your_domain.com"
objMessage.TextBody = "Send " & Filename & " via Outlook+Calibre"
objMessage.AddAttachment Full_Filename
objMessage.Send

WScript.Echo "Mail successed!"

vbscript 使用Outlook夹带档案寄信。新版Outlook会出现提示，要求允许寄信。

使用Outlook夹带档案寄信。新版Outlook会出现提示，要求允许寄信。

sendmail_via_outlook.vbs

' http://www.rgagnon.com/wshdetails/wsh-0018.html
' http://www.rgagnon.com/wshdetails/wsh-0002.html
' http://www.bernhard-ehlers.de/projects/OutlookSecurity.html

' Get full filepath from 1st argument
Dim Full_Filename
Dim Filename
Set objArgs = WScript.Arguments
if WScript.Arguments.Count=0 then
  WScript.Quit 1
end if
' WScript.Echo objArgs(0)
Full_Filename = objArgs(0)

' Parse to simple filename
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(Full_Filename)
Filename = objFSO.GetFileName(objFile)
Set objFile = Nothing
Set objFSO = Nothing

' Start to mail
Dim ToAddress
Dim MessageSubject
Dim MessageBody
Dim MessageAttachment
ToAddress = "your_user@your_domain.com"   ' change this...
MessageSubject = Filename
MessageBody = "Send " & Filename & " via Outlook"
MessageAttachment = Full_Filename

Dim ol, ns, newMail
Set ol = WScript.CreateObject("Outlook.Application")
Set ns = ol.getNamespace("MAPI")
ns.logon "","",true,false
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.Body = MessageBody & vbCrLf

' validate the recipient, just in case...
Set myRecipient = ns.CreateRecipient(ToAddress)
myRecipient.Resolve
If Not myRecipient.Resolved Then
   MsgBox "unknown recipient"
Else
   newMail.Recipients.Add(myRecipient)
   newMail.Attachments.Add(MessageAttachment).Displayname = Filename
   newMail.Send
   WScript.Echo "Mail successed! " & Full_Filename
End If

Set ol = Nothing

vbscript 有用的宏观：[2015年1月20日]

有用的宏观：[2015年1月20日]

SectionCONCATENATE.vbs

Private Sub SectionCONCATENATE()
Dim nROWS As Long, nCOLM As Long, c As Long
    nROWS = Selection.Rows.Count
    nCOLM = Selection.Columns.Count

'Vertical Data Set: When there are More than 2 No. of ROWS
    If 1 = nCOLM And 2 < nROWS Then
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=RC[-1]"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(nROWS - 1, 1).Select
    
        Range(Selection, Selection.End(xlUp)).Select
        Selection.FillDown
    
        ActiveCell.Offset(nROWS - 2, nCOLM - 1).Select
    
        Selection.Copy

'Vertical Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nCOLM And 2 = nROWS Then
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=RC[-1]"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""'"",RC[-1],""'"")"
        
        ActiveCell.Select
        Selection.Copy

'Horizontal Data Set: When there are More than 2 No. of ROWS
    ElseIf 1 = nROWS And 2 < nCOLM Then
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=R[-1]C"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(1, nCOLM - 1).Select
    
        Range(Selection, Selection.End(xlToLeft)).Select
        ActiveCell.Select
        
            For c = 1 To nCOLM - 2
                ActiveCell.Offset(0, 1).Select
                'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
                ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
            Next c
        Selection.Copy
        
'Horizontal Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nROWS And 2 = nCOLM Then
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=R[-1]C"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
        
        ActiveCell.Select
        Selection.Copy
    Else
        MsgBox ("Please select either more than 1 row or more than 1 column of data!")
    
    End If
End Sub

INCEPTION.vbs

Private Sub auto_open()
    Run ("DelUMContextMenu")    'Calls the function 'DelUMContextMenu' which delete the context menu item 'USEFUL MACROS' if already there to avoide any possible duplication!
    Run ("UMContextMenu")   'Calls the function 'UMContextMenu' which builds a new context menu item as 'USEFUL MACROS'!
End Sub


Private Sub auto_close()
    Run ("DelUMContextMenu")    'Calls the function 'DelUMContextMenu' which delete the context menu of already there to avoide possible duplication!
    Run ("ResUMContextMenu")    'Calls the function 'ResUMContextMenu' which reset the context menu to MS Excel's default!
End Sub

ContextMENU.vbs

Private Sub UMContextMenu()
    Dim ContextMENU As CommandBar
    Dim MySubMenu As CommandBarControl

    'Delete the controls first to avoid duplicates
    Call DelUMContextMenu

    'Set ContextMenu to the Cell menu
    Set ContextMENU = Application.CommandBars("Cell")
    
    'Add custom menu with three buttons
    Set MySubMenu = ContextMENU.Controls.Add(Type:=msoControlPopup, before:=1)

    With MySubMenu
        .Caption = "USEFUL MACROS"
        .Tag = "UsefulMacro"
        .BeginGroup = True
        
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "OpenCalendar"
            .FaceId = 8
            .Caption = "FILL-DATE"
        End With
        
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "SplitROWS"
            .FaceId = 295
            .Caption = "SPLIT-ROWS"
        End With
                        
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "TickCLEANER"
            .FaceId = 292
            .Caption = "TICK-CLEANER"
        End With
        
        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "CleanPhoneNo"
            .FaceId = 250
            .Caption = "CLEAN PHONE No"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "SectionCONCATENATE"
            .FaceId = 382
            .Caption = "CONCATENATE"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "SingleQuotesCONCATENATE"
            .FaceId = 382
            .Caption = "'CONCATENATE'"
        End With
        

        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "SquareBracketCONCATENATE"
            .FaceId = 382
            .Caption = "[CONCATENATE]"
        End With

        
        'With .Controls.Add(Type:=msoControlButton)
            '.OnAction = "'" & ThisWorkbook.Name & "'!" & "MergeSHEETS"
            '.FaceId = 159
            '.Caption = "MERGE-SHEETS"
        'End With
                
        'With .Controls.Add(Type:=msoControlButton)
            '.OnAction = "'" & ThisWorkbook.Name & "'!" & "RHISTORY"
            '.FaceId = 250
            '.Caption = "RHISTORY-FORMAT"
        'End With

        With .Controls.Add(Type:=msoControlButton)
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "SUPPORT"
            .FaceId = 49
            .Caption = "SUPPORT!"
        End With
        
        
    End With

    'Add seperator to the Cell menu
    'ContextMENU.Controls(4).BeginGroup = True
End Sub



Private Sub DelUMContextMenu()  'Delete the context menu of already there!
    Dim ctrl As CommandBarControl
     'go thru all the cell commandbar controls and delete our menu item
    For Each ctrl In Application.CommandBars("Cell").Controls
        If ctrl.Caption = "USEFUL MACROS" Then ctrl.Delete
    Next
End Sub


Private Sub ResUMContextMenu()  'Reset the context menu to MS Excel's default!
    Application.CommandBars("Cell").Reset
End Sub

ARCHIVE.vbs

Option Explicit


Private Sub OpenCalendar()
   UfCalendar.Show
End Sub


Private Sub SUPPORT()   'Opens the Support webpage when the support contect menu is clicked.
    ActiveWorkbook.FollowHyperlink Address:="http://ashiskumar.wordpress.com/visual-basic/useful-macros/"
End Sub

Private Sub SplitROWS()
Dim vROW As Long, fROW As Long, sSET As Long
    
On Error GoTo GetOut
    vROW = InputBox(Prompt:="Please enter the number of rows that the worksheet is to be splitted with.", Title:="Split Workbook By?") + 1
    fROW = vROW
    sSET = 1
        Do Until Len(Cells(vROW, 1)) = 0
            Rows(vROW).Insert Shift:=xlDown
            vROW = vROW + fROW
            sSET = sSET + 1
        Loop
    MsgBox ("The worksheet has been splitted into " & sSET & " different sets of rows of data.")
GetOut:
End Sub


Private Sub SectionCONCATENATE()
Dim nROWS As Long, nCOLM As Long, c As Long
    nROWS = Selection.Rows.Count
    nCOLM = Selection.Columns.Count

'Vertical Data Set: When there are More than 2 No. of ROWS
    If 1 = nCOLM And 2 < nROWS Then
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=RC[-1]"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(nROWS - 1, 1).Select
    
        Range(Selection, Selection.End(xlUp)).Select
        Selection.FillDown
    
        ActiveCell.Offset(nROWS - 2, nCOLM - 1).Select
    
        Selection.Copy

'Vertical Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nCOLM And 2 = nROWS Then
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=RC[-1]"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""'"",RC[-1],""'"")"
        
        ActiveCell.Select
        Selection.Copy

'Horizontal Data Set: When there are More than 2 No. of ROWS
    ElseIf 1 = nROWS And 2 < nCOLM Then
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=R[-1]C"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(1, nCOLM - 1).Select
    
        Range(Selection, Selection.End(xlToLeft)).Select
        ActiveCell.Select
        
            For c = 1 To nCOLM - 2
                ActiveCell.Offset(0, 1).Select
                ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
                'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
            Next c
        Selection.Copy
        
'Horizontal Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nROWS And 2 = nCOLM Then
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=R[-1]C"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
        
        ActiveCell.Select
        Selection.Copy
    Else
        MsgBox ("Please select either more than 1 row or more than 1 column of data!")
    
    End If
End Sub




Private Sub SingleQuotesCONCATENATE()
Dim nROWS As Long, nCOLM As Long, c As Long
    nROWS = Selection.Rows.Count
    nCOLM = Selection.Columns.Count

'Vertical Data Set: When there are More than 2 No. of ROWS
    If 1 = nCOLM And 2 < nROWS Then
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=RC[-1]"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(nROWS - 1, 1).Select
    
        Range(Selection, Selection.End(xlUp)).Select
        Selection.FillDown
    
        ActiveCell.Offset(nROWS - 2, nCOLM - 1).Select
    
        Selection.Copy

'Vertical Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nCOLM And 2 = nROWS Then
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=RC[-1]"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",RC[-1],""'"")"
        
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""'"",RC[-1],""'"")"
        
        ActiveCell.Select
        Selection.Copy

'Horizontal Data Set: When there are More than 2 No. of ROWS
    ElseIf 1 = nROWS And 2 < nCOLM Then
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=R[-1]C"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(1, nCOLM - 1).Select
    
        Range(Selection, Selection.End(xlToLeft)).Select
        ActiveCell.Select
        
            For c = 1 To nCOLM - 2
                ActiveCell.Offset(0, 1).Select
                'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
                ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
            Next c
        Selection.Copy
        
'Horizontal Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nROWS And 2 = nCOLM Then
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=R[-1]C"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""'"",R[-1]C,""'"")"
        
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""'"",R[-1]C,""'"")"
        
        ActiveCell.Select
        Selection.Copy
    Else
        MsgBox ("Please select either more than 1 row or more than 1 column of data!")
    
    End If
End Sub

Private Sub SquareBracketCONCATENATE()
Dim nROWS As Long, nCOLM As Long, c As Long
    nROWS = Selection.Rows.Count
    nCOLM = Selection.Columns.Count

'Vertical Data Set: When there are More than 2 No. of ROWS
    If 1 = nCOLM And 2 < nROWS Then
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=RC[-1]"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""["",RC[-1],""]"")"
        
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""["",RC[-1],""]"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(nROWS - 1, 1).Select
    
        Range(Selection, Selection.End(xlUp)).Select
        Selection.FillDown
    
        ActiveCell.Offset(nROWS - 2, nCOLM - 1).Select
    
        Selection.Copy

'Vertical Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nCOLM And 2 = nROWS Then
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=RC[-1]"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""["",RC[-1],""]"")"
        
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",""["",RC[-1],""]"")"
        
        ActiveCell.Select
        Selection.Copy

'Horizontal Data Set: When there are More than 2 No. of ROWS
    ElseIf 1 = nROWS And 2 < nCOLM Then
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=R[-1]C"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""["",R[-1]C,""]"")"
        
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""["",R[-1]C,""]"")"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(1, nCOLM - 1).Select
    
        Range(Selection, Selection.End(xlToLeft)).Select
        ActiveCell.Select
        
            For c = 1 To nCOLM - 2
                ActiveCell.Offset(0, 1).Select
                'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
                ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""["",R[-1]C,""]"")"
            Next c
        Selection.Copy
        
'Horizontal Data Set: When there are 2 No. of ROWS!
    ElseIf 1 = nROWS And 2 = nCOLM Then
        ActiveCell.Offset(1, 0).Select
        'ActiveCell.FormulaR1C1 = "=R[-1]C"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(""["",R[-1]C,""]"")"
        
        ActiveCell.Offset(0, 1).Select
        'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",""["",R[-1]C,""]"")"
        
        ActiveCell.Select
        Selection.Copy
    Else
        MsgBox ("Please select either more than 1 row or more than 1 column of data!")
    
    End If
End Sub



Private Sub TickCLEANER()
Dim ColNO As Integer, rDEL As Long, sTIME As Date
On Error Resume Next
ColNO = InputBox("Please enter the column number to check for blank cell or cell with '0' value." & vbCrLf & vbCrLf & "Rows matching with the criteria will be deleted!", "Enter Column No. for Check & Row Delete...")
    If 0 = ColNO Then Exit Sub
    ThisWorkbook.ActiveSheet.Activate
    ActiveSheet.Cells(2, ColNO).Select
    sTIME = Now()
        Do While ActiveCell.Offset(0, ColNO - ((ColNO * 2) - 1)).Value <> ""
            If ActiveCell.Value = 0 Or ActiveCell.Value = "" Then
                Selection.EntireRow.Delete
                rDEL = rDEL + 1
            Else: ActiveCell.Offset(1, 0).Select
            End If
        Loop
    MsgBox ("Deleted " & rDEL & " rows of data in " & Format(Now() - sTIME, "HH:MM:SS") & " seconds!")
    End Sub

Private Sub TickNEATER()
Dim ColNO As Integer, RowNO As Long, rDEL As Long, sTIME As Date
RowNO = 2
ColNO = InputBox("Please enter the column number to check for blank cell or cell with '0' value whose row is to be deleted!", "Enter the column for checking...")
    If 0 = ColNO Then Exit Sub
    ThisWorkbook.ActiveSheet.Activate
    ActiveSheet.Cells(RowNO, ColNO).Select
    sTIME = Now()
        Do While ActiveSheet.Cells(RowNO, ColNO - (ColNO - 1)).Value <> ""
            If ActiveCell.Value <> 0 Or ActiveCell.Value <> "" Then
                RowNO = RowNO + 1
                ActiveSheet.Cells(RowNO, ColNO).Select
            Else
                Selection.EntireRow.Delete
                rDEL = rDEL + 1
            End If
        Loop
    MsgBox ("Deleted " & rDEL & " rows of data in " & Format(Now() - sTIME, "HH:MM:SS") & " seconds!")
End Sub
MsgBox ("Deleted " & rDEL & " rows of data in " & Format(Now() - sTIME, "HH:MM:SS") & " seconds!")
End Sub

Private Sub CleanPhoneNo()
Dim Remove(), nROWS As Integer, x As Integer, i As Variant

On Error Resume Next
nROWS = Selection.Rows.Count
ThisWorkbook.ActiveSheet.Activate
ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column + 1).Select
Remove() = Array("~", "`", "!", "@", "#", "$", "%", "^", "&", "(", ")", "-", "_", "=", "{", "}", "[", "]", "\", "|", ";", ":", "'", ",", "<", ">", "/", " ")

    For x = 1 To nROWS
        ActiveCell.Value = "'" & ActiveCell.Offset(0, -1).Value
        
        For Each i In Remove()
            ActiveCell.Replace What:=i, Replacement:="", MatchCase:=True
        Next i
        
        If Left(ActiveCell.Value, 1) = "+" Then ActiveCell.Replace What:=Left(ActiveCell.Value, 3), Replacement:="", MatchCase:=True
        If Left(ActiveCell.Value, 1) = "0" Then ActiveCell.Replace What:=Left(ActiveCell.Value, 1), Replacement:="", MatchCase:=True
        If Left(ActiveCell.Value, 1) = "0" Then ActiveCell.Replace What:=Left(ActiveCell.Value, 1), Replacement:="", MatchCase:=True

        ActiveCell.Value = "'" & ActiveCell.Offset(0, -2).Value & ActiveCell.Value

        ActiveCell.Offset(1, 0).Select
    Next x
    
End Sub

vbscript 有用的宏：[2015年1月14日]

有用的宏：[2015年1月14日]

SectionCONCATENATE.vbs

Private Sub SectionCONCATENATE()
Dim nROWS As Long, nCOLM As Long, c As Long
    nROWS = Selection.Rows.Count
    nCOLM = Selection.Columns.Count

    If 1 = nCOLM And 2 < nROWS Then
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=""'"",RC[-1]," '""
        
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(nROWS - 1, 1).Select
    
        Range(Selection, Selection.End(xlUp)).Select
        Selection.FillDown
    
        ActiveCell.Offset(nROWS - 2, nCOLM - 1).Select
    
        Selection.Copy
        
    ElseIf 1 = nCOLM And 2 = nROWS Then
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=RC[-1]"
        
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,"","",RC[-1])"
        
        ActiveCell.Select
        Selection.Copy
        
    ElseIf 1 = nROWS And 2 < nCOLM Then
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=R[-1]C"
        
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        
        ActiveCell.Offset(-1, -1).Select
    
        Selection.Resize(nROWS, nCOLM).Select
        ActiveCell.Offset(1, nCOLM - 1).Select
    
        Range(Selection, Selection.End(xlToLeft)).Select
        ActiveCell.Select
        
            For c = 1 To nCOLM - 2
                ActiveCell.Offset(0, 1).Select
                ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
            Next c
        Selection.Copy
        
        
    ElseIf 1 = nROWS And 2 = nCOLM Then
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "=R[-1]C"
        
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],"","",R[-1]C)"
        
        ActiveCell.Select
        Selection.Copy
    Else
        MsgBox ("Please select either more than 1 row or more than 1 column of data!")
    
    End If
End Sub

vbscript 使用VBScript发送电子邮件

使用VBScript发送电子邮件

SendEmailFromVBS.vbs

Sub Send_Email()
'
' Send_Email Macro
' send an email
'
' Keyboard Shortcut: Ctrl+Shift+E
'
   
Set emailObj = CreateObject("CDO.Message")

emailObj.From = "Username@gmail.com"
emailObj.To = "IntendedRecipient@gmail.com"

emailObj.Subject = "Test CDO subject"
emailObj.TextBody = "Test CDO body"

Set emailConfig = emailObj.Configuration

emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Username@gmail.com"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "UserPasswordHere"

emailConfig.Fields.Update

emailObj.Send

If Err.Number = 0 Then MsgBox "Email Sent!"

End Sub

vbscript 该代码将一个服务器名称替换为Excel连接中的另一个服务器名称。

该代码将一个服务器名称替换为Excel连接中的另一个服务器名称。

v1_UpdateCONNECTIONS.vbs

Sub UpdateCONNECTIONS()
Dim CON As Variant, NewSERVER As String, OldSERVER As String, SvrConAVAL As Integer

If MsgBox("The action will requir you to have both, New & Old Server Name!", vbYesNo, "Server Name Confirm?") = vbNo Then Exit Sub
    OldSERVER = InputBox("Please enter the new server name:", "New Server", "nbmsaadev01.mgmt.lab.eng.btc.netapp.in")
    NewSERVER = InputBox("Please enter the new server name:", "New Server", "amsmsaapp02-prd.hq.netapp.com")

    For Each CON In ActiveWorkbook.Connections
        CON.OLEDBConnection.Connection = Replace(CON.OLEDBConnection.Connection, OldSERVER, NewSERVER)
    Next CON
End Sub

UpdateCONNECTIONS.vbs

Sub UpdateCONNECTIONS()
Dim CON As Variant, NewSERVER As String, OldSERVER As String

NewSERVER = "amsmsaapp02-prd.hq.netapp.com"
OldSERVER = "nbmsaadev01.mgmt.lab.eng.btc.netapp.in"

  For Each CON In ActiveWorkbook.Connections
      CON.OLEDBConnection.Connection = Replace(CON.OLEDBConnection.Connection, OldSERVER, NewSERVER)
  Next CON

End Sub