常用VBA小技巧

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

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

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

?

1	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(3)).Name = SheetName
    End If
    
End 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 = -1 Then                                     'Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）
                SelectedDataPath = .SelectedItems(1)
            Else    '说明用户按了'取消'按钮，则提示程序将退出.
                Err.Raise Number:=512 + 1, Description:='You click cancel buttion. Program will terminate.'
            End If
        End With

End 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 = -1 Then                                     'Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）
            'SelectedDataPath = .SelectedItems(1)
            Set FileItems = .SelectedItems
        Else    '说明用户按了'取消'按钮，则提示程序将退出.
            Err.Raise Number:=512 + 1, Description:='You click cancel buttion. Program will terminate.'
        End If
    End With
    
    
    For Each VrtItem In FileItems
        If InStr(CStr(VrtItem), 'BrillianceAQM') > 0 Then                   'UBS
            Call GetCiccDataForOnefund(WktUBS, CStr(VrtItem))
        ElseIf InStr(CStr(VrtItem), 'BRILLIANCE_') > 0 Then             'BPFL
            Call GetCiccDataForOnefund(WktBPFL, CStr(VrtItem))
        ElseIf InStr(CStr(VrtItem), 'ChinaCoreFund_') > 0 Then          'CCF
            Call GetCiccDataForOnefund(WktCCF, CStr(VrtItem))
        ElseIf InStr(CStr(VrtItem), 'rep_position_by_custodian_CICC') > 0 Then          ' PMS custodian: CICC
            Call GetCiccPMSData(WktPMS, CStr(VrtItem))
        Else
            Err.Raise Number:=512 + 13, 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, 1) = 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 > 0 Then                                                                          ' 如果 存在data connections链接，则先存储其names, 再利用names将其循环删除.
        ReDim AryConName(1 To ConNum) As String
        
        For Idx = 1 To ConNum
            AryConName(Idx) = Wb.Connections.Item(Idx).Name
            Debug.Print '[In DeleteDataConnections ] ------------>idx = ' & Idx & '    AryConName(Idx) = ' & AryConName(Idx)
        Next
    
        For Idx = 1 To ConNum                                                                   ' 利用name来循环删除，而非利用 wb.Connections.Item(idx)
            Wb.Connections(AryConName(Idx)).Delete
        Next
    End If
    

End Sub