常用VBA小技巧

用对话框选取文件路径(单个文件)

删除导入csv等文本文件后留下的 Data connections

• 增加新的工作表并并命名

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "333"

• 检查工作表是否存在，若不存在则新建

'参数：
'           SheetName: 工作表名字
'功能：
'           检查以SheetName为工作表名字的worksheet是否存在，若不存在，则新建.
Private Sub CheckCreateNewWorksheet(SheetName As String)
    Dim ExistsFlag As Boolean       ' ExistsFlag: true-SheetName的工作表存在； false-不存在
    Dim St As Worksheet    ExistsFlag = False
    For Each St In Worksheets
        If St.Name = SheetName Then
            ExistsFlag = True
            Exit For
        End If
    Next    '如果以SheetName为工作表名字的worksheet不存在，则新建它
    If ExistsFlag = False Then
            Worksheets.Add(After:=Worksheets()).Name = SheetName
    End IfEnd Sub

• 路径中提取最后的文件名

'从路径C:\ab\c\d.txt 中提取文件名 d.txt
Public Function GetfileName(FilePath As String) As String
    Dim strTemp() As String
    strTemp = VBA.Split(FilePath, "\")
    GetfileName = strTemp(UBound(strTemp))
End Function

• 用对话框选取文件路径  （单个文件）

'得到指定文件的全路径' 出口参数：SelectedDataPath     选择的文件的全路径' TitleDisplayed    ：展示的标题
' InitalPath：          起始的路径
Private Sub GetFilePathFromDialog(SelectedDataPath As String, TitleDisplayed As String, InitalPath As String)        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = TitleDisplayed           ' "Select The Portfolio Holding Report:"
            .InitialFileName = InitalPath       '   "\\192.168.0.200\files\administrative\Operation\Daily PMS\"      '打开对话框后的默认展示路径，增加易用性
            .AllowMultiSelect = False    '不允许多选
            .Filters.Clear                    '清除过滤器
            '.Filters.Add "Excel Files", "*.xls;*.xlw;*.xlsx;*.xlsm"      '设置两个过滤器
            .Filters.Add "All Files", "*.*"
            If .Show = - Then                                     'Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）
                SelectedDataPath = .SelectedItems()
            Else    '说明用户按了"取消"按钮，则提示程序将退出.
                Err.Raise Number:= + , Description:="You click cancel buttion. Program will terminate."
            End If
        End WithEnd Sub

• 用对话框选取文件路径（可以一次性选取多个文件： 主要利用 .AllowMultiSelect = True ）

' 将待做CICC的 Pos rec的数据通过点选文件的方式拷贝到对应的表格
Public Sub GetCiccPosRecData(WktPMS As Worksheet, WktBPFL As Worksheet, WktCCF As Worksheet, WktUBS As Worksheet)
    Application.ScreenUpdating = False    Dim FileItems As FileDialogSelectedItems
    Dim VrtItem As Variant    '通过多选的方式，选定所有文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True                                                                           ' 允许多选
        .Title = "please select the files regarding to CICC position rec."
        .InitialFileName = WktPMS.Parent.Path                                                       ' 打开对话框后的默认展示路径，增加易用性
        .Filters.Clear                                                                                          ' 清除过滤器
        .Filters.Add "Excel Files", "*.xls;*.xlw;*.xlsx;*.xlsm;*.csv;*.XLS"      '设置两个过滤器
        '.Filters.Add "All Files", "*.*"
        If .Show = - Then                                     'Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）
            'SelectedDataPath = .SelectedItems(1)
            Set FileItems = .SelectedItems
        Else    '说明用户按了"取消"按钮，则提示程序将退出.
            Err.Raise Number:= + , Description:="You click cancel buttion. Program will terminate."
        End If
    End With    For Each VrtItem In FileItems
        If InStr(CStr(VrtItem), "BrillianceAQM") >  Then                   'UBS
            Call GetCiccDataForOnefund(WktUBS, CStr(VrtItem))
        ElseIf InStr(CStr(VrtItem), "BRILLIANCE_") >  Then             'BPFL
            Call GetCiccDataForOnefund(WktBPFL, CStr(VrtItem))
        ElseIf InStr(CStr(VrtItem), "ChinaCoreFund_") >  Then          'CCF
            Call GetCiccDataForOnefund(WktCCF, CStr(VrtItem))
        ElseIf InStr(CStr(VrtItem), "rep_position_by_custodian_CICC") >  Then          ' PMS custodian: CICC
            Call GetCiccPMSData(WktPMS, CStr(VrtItem))
        Else
            Err.Raise Number:= + , Description:="An new file name. Please check manually."
        End If
    Next    Application.ScreenUpdating = True    Debug.Print "--------------------"End Sub

• Transpose 将横向的一维数组转置到 excel的列中

  WktOutput.Range("A2").Resize(DicAll.Count, ) = Application.WorksheetFunction.Transpose(DicAll.Keys)       将 DicAll.Keys 这个数组 转置到 A 列

• 拷贝工作表，从workbook1拷贝到 workbook2

•         WbOMS.Worksheets("Sheet").Cells.Copy
          WktOmsOri.Range("A1").PasteSpecial xlPasteAll        WbSMY.Worksheets(StrDate).Cells.Copy
          WktSmyOri.Range("A1").PasteSpecial xlPasteAll

• 避免剪贴后出现对话框

'在粘贴后，加一句CutCopyMode  = False的代码 ，以清空剪贴板.    Wkt.Cells.Copy WktDest.Range("A1")
    Application.CutCopyMode = False    '关闭 Source File
    Wkb.Save
    Wkb.Close'如下代码需成对出现    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

• 用数组给单元格批量赋值

    Dim AryTitle as Variant
　  AryTitle = Array("Ticker", "Last Price", "Current Price", "Diff", "Only In Last", "Only In Current")
    Wkt.Range("A1:F1").Value = AryTitle  '注意 Range的大小要和数组的长度相同.
    Wkt.Range("A1:F1").Font.Bold = True

• 关闭某个window窗口

Windows("TEST_FOR_0227_Merill_Lynch_DB_GS.xlsm").WindowState = xlMinimized

　　其中Windows()的参数为窗口名称。

• 删除导入csv等文本文件后留下的 Data connections

' Function:
'           delete all the data connnections to avoid leaving many unuseful data connections behind
Public Sub DeleteDataConnections()    Application.DisplayAlerts = False    Dim Wb As Workbook
    Dim AryConName() As String                                                              ' 存储data connections名字的数组
    Dim ConNum As Integer
    Dim Idx As Integer    Set Wb = ThisWorkbook
    ConNum = Wb.Connections.Count
    Debug.Print "[In DeleteDataConnections ]  Wb.Connections.Count = " & Wb.Connections.Count    If ConNum >  Then                                                                          ' 如果 存在data connections链接，则先存储其names, 再利用names将其循环删除.
        ReDim AryConName( To ConNum) As String        For Idx =  To ConNum
            AryConName(Idx) = Wb.Connections.Item(Idx).Name
            Debug.Print "[In DeleteDataConnections ] ------------>idx = " & Idx & "    AryConName(Idx) = " & AryConName(Idx)
        Next        For Idx =  To ConNum                                                                   ' 利用name来循环删除，而非利用 wb.Connections.Item(idx)
            Wb.Connections(AryConName(Idx)).Delete
        Next
    End IfEnd Sub