VBA_50段代码总结

'
'                                                          30个有用的VBA代码

'目录：

'1--合理使用数组：
'2--一次保存并关闭所有工作簿:
'3--限制光标在特定区域的移动  如果要限制工作表中的滚动区域，可以使用以下代码执行此操作：
'4--01--将筛选后的数据复制到新工作簿中:
'4--02--将筛选后的数据复制到新工作簿中--Ivan做的：
'5--将所有公式转换为选定数据集中的值:
'6--在单个单元格中获取多个查找值
'7--显示多个隐藏的工作表:
'8--隐藏除了活动工作表外的所有工作表:
'9--用VBA代码按字母的顺序对工作表进行排序
'10--一次性保护所有的工作表(带密码保护)
'11--一次性取消所有的工作表保护
'12--突出显示所选内容中的可选行
'13--突出显示拼错单词的单元格
'14--刷新工作簿中的所有透视表
'15--将所选单元格的字母大小写改为大写
'16--突出显示有批注的单元格
'17--将所有公式转换为值
'18--有公式的单元格锁定
'19--保护工作簿中所有的工作表(不带密码保护)
'20--在所选内容中每隔一行后插入一行
'21--自动在相邻单元格中插入日期和时间戳
'22--显示所有隐藏的行和列
'23--取消所有的合并单元格
'24--保存带有时间戳的工作簿
'25--将工作表另存为一个PDF文件
'26--将工作簿另存为单独的PDF文件
'27--突出显示所选数据集中的空白单元格
'28--按单列对数据排序
'29--按多列对数据排序
'30--如何只从字符串中获取数字部分
'31--总是在激活特定选项卡的情况下打开工作簿
'32--根据文件全路径名取文件名
'33--获取文件名的后缀名 instrrev()函数的使用
'34--清空某列
'35--获取数据起始行
'36--获取某列的最后一行（有数据的最后一行）
'37--格式化字符串
'38--利用字典对指定列去重(不改变原列，去重后存到字典的Key中)
'39--数字转列号字母，
'40--列号字母转数字
'41--遍历字典
'42-1-把两列添加到字典中，其中一列为key,另一列为value
'42-2-将指定三列的一列作为Key和两外两列作为Value添加到字典中
'43--loop files
'44-1--使用一维数组对单元格赋值
'44-2--使用二维数组对单元格赋值
'45--使用find()函数代替for each 循环
'46--读取环境变量的方法1--VBA.environ(name)
'47--读取环境变量的方法2--readuserenviron(name)
'48--对合并了的单元格的查找

 

'1--合理使用数组：
'先给数组赋值，再通过Application.WorksheetFunction.Transpose(arr)给单元格赋值速度极快于通过循环单元格的方式给单元格直接赋值。

Sub InputArr()
    Dim start As Double
    start = Timer
    Dim i As Long, arr(1 To 65536) As Long
   
    For i = 1 To 65536
        arr(i) = i
    Next
   
    Range("A1:A65536").Value = Application.WorksheetFunction.Transpose(arr)
    MsgBox "程序运行时间约是 " & Format(Timer - start, "0.00") & "秒。"

End Sub

'2--一次保存并关闭所有工作簿:
Sub CloseAllWorkbooks()
    Dim wb As Workbook
    For Each wb In Workbooks
        wb.Close savechanges:=True
    Next wb
End Sub

'3--限制光标在特定区域的移动  如果要限制工作表中的滚动区域，可以使用以下代码执行此操作：

Private Sub Worksheet_Open()
    Sheets("Sheet1").ScrollArea = "A1:M17"
End Sub

'4--01--将筛选后的数据复制到新工作簿中:
'如果您使用的是一个巨大的数据区域，那么过滤器在分割数据时非常有用。有时，您可能只需要数据区域的一部分。
'在这种情况下，您可以使用下面的代码将筛选后的数据快速复制到新工作表中。

Sub CopyFilteredData()
    If ActiveSheet.AutoFilterMode = False Then
        Exit Sub
    End If
    ActiveSheet.AutoFilter.Range.Copy
    Workbooks.Add.Worksheets(1).Paste
    Cells.EntireColumn.AutoFit
End Sub
'此代码首先检查是否有任何已筛选的数据,否则，它会复制筛选后的数据，插入新工作簿，并将数据粘贴到其中。

'4--02--将筛选后的数据复制到新工作簿中--Ivan做的：
'this function is designed to Filter Apro file to get valid records.
    'If SHAR flag is YES or RSU SO EYSMS flag is YES, we do filtering of Apro file as temp file for further processing.
    'In Apro file, we only pick the record with Relocation Phase having values listed in "Apro Relcation Phase" in "Misc_Config" sheet of parm file.This can be used as a temp file
    'If any error, control report is updated.

Sub PreApro()
On Error GoTo errorhandler
    Dim wb_new_apro As Workbook
    Dim ws_new_apro As Worksheet
    Dim int_last_row_parm As Long
    Dim int_last_row_input As Long
    Dim str_filter() As String
    Dim i As Long
    Dim ws_apro_input As Worksheet
   
    My_Err = "PreProcess module error - PreApro sub error."
   
    If Get_SHAR_CheckBox_Flag = True Or Get_RSUSOEYSMS_CheckBox_Flag = True Then
        int_last_row_parm = getLastValidRow(ThisWorkbook.Worksheets("Misc_Config"), "M")
        ReDim str_filter(1 To int_last_row_parm - 1)
        For i = 2 To int_last_row_parm
            str_filter(i - 1) = Trim(ThisWorkbook.Worksheets("Misc_Config").Range("M" & i))
        Next
       
        Set wb_new_apro = Workbooks.Add
        Set ws_new_apro = wb_new_apro.Worksheets(1)
       
        openF2_Apro_File
        Set ws_apro_input = wb_F2_Apro_File.Worksheets(1)
        int_last_row_input = getLastValidRow(ws_apro_input, "A")
        If ws_apro_input.AutoFilterMode = True Then
            ws_apro_input.AutoFilterMode = False
        End If
        ws_apro_input.Range("$A$3:$AF$" & int_last_row_input).AutoFilter Field:=2, Criteria1:=str_filter, Operator:=xlFilterValues

        'ws_apro_input.Range("A1:AF" & int_last_row_input).Copy ws_new_apro.Range("A1")
        ws_apro_input.Range("A1:AF" & int_last_row_input).SpecialCells(xlCellTypeVisible).Copy ws_new_apro.Range("A1")
       
        ws_new_apro.Cells.WrapText = False
        ws_new_apro.Columns("A:AF").AutoFit
       
        ws_new_apro.Name = ws_apro_input.Name
        If verifyFileExist(get_F30_Apro_Filter_File) Then
            Kill get_F30_Apro_Filter_File
        End If
        wb_new_apro.SaveAs Filename:=get_F30_Apro_Filter_File
       
        closeF2_Apro_File False
        wb_new_apro.Close savechanges:=True
    End If

End Sub

'5--将所有公式转换为选定数据集中的值:
'如果要快速将所有具有公式的单元格转换为值，可以使用以下代码：
Sub ConvertFormulastoValues()
    Dim Myrange As Range
    Dim MyCell As Range
    Set Myrange = Selection
    For Each MyCell In Myrange
        If MyCell.HasFormula Then
        MyCell.Formula = MyCell.Value
    End If
    Next MyCell
End Sub
'注意这个变化是不可逆的，公式将无法恢复。
'或者，你也可以编写一个消息框，显示公式将丢失的警告。这可以防止用户意外运行此宏

'6--在单个单元格中获取多个查找值
'如果要查找表中的值并在同一单元格中获取所有匹配结果，则需要使用VBA创建自定义函数。
'下面是创建了一个公式，类似VLOOKUP。

Function GetMultipleLookupValues(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)
    Dim i As Long
    Dim Result As String
    For i = 1 To LookupRange.Columns(1).Cells.count
        If LookupRange.Cells(i, 1) = Lookupvalue Then
            Result = Result & " " & LookupRange.Cells(i, ColumnNumber) & ","
        End If
    Next i
    GetMultipleLookupValues = Left(Result, Len(Result) - 1)
End Function
'注意，这个函数有三个参数：
'Lookupvalue  – 需要查询的值
'LookupRange  – 需要查询的区域
'ColumnNumber – 提取结果的列号

'7--1.显示多个隐藏的工作表:
'如果你的工作簿里面有多个隐藏的工作表，你需要花很多时间一个一个的显示隐藏的工作表。
'下面的代码，可以让你一次显示所有的工作表

Sub UnhideAllWoksheets()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws
End Sub

'8--隐藏除了活动工作表外的所有工作表:
'如果你做的报表，希望隐藏除了报表工作表以外的所有工作表，则可以用一下代码来实现：

Sub HideAllExcetActiveSheet()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> ActiveSheet.Name Then
        ws.Visible = xlSheetHidden
    End If
    Next ws
End Sub

'9--用VBA代码按字母的顺序对工作表进行排序
'如果你有一个包含多个工作表的工作簿，并且希望按字母对工作表进行排序，那么下面的代码，可以派上用场。

Sub SortSheetsTabName()
    Application.ScreenUpdating = False
    Dim ShCount As Integer, i As Integer, j As Integer
    ShCount = Sheets.count
    For i = 1 To ShCount - 1
        For j = i + 1 To ShCount
            If Sheets(j).Name < Sheets(i).Name Then
                Sheets(j).Move before:=Sheets(i)
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

'10--一次性保护所有的工作表(带密码保护)
'如果工作薄里面有多个工作表，并且希望保护所有的工作表，那么下面的代码，可以派上用场。

Sub ProtectAllSheets()
    Dim ws As Worksheet
    Dim password As String
    '用你想要的密码替换Test123
    password = "Test123"
    For Each ws In Worksheets
        ws.Protect password:=password
    Next ws
End Sub

'11--一次性取消所有的工作表保护
'如果你保护了你所有的工作表，那么你只需要修改一下代码，就可以取消所有工作表的保护。

Sub ProtectsAllSheets()
    Dim ws As Worksheet
    Dim password As String
    '用你想要的密码替换Test123
    password = "Test123"
     For Each ws In Worksheets
     ws.Unprotect password:=password
     Next ws
End Sub
'需要注意的是，取消保护工作表的密码， 要与锁定工作表的密码相同，否则程序会抛出异常（出错）。

'12--突出显示所选内容中的可选行
'突出显示可选行可以极大地提高数据的可读性?
'下面是一个代码，它将立即突出显示所选内容中的可选行。

Sub HighlightAlternateRows()
    Dim Myrange As Range
    Dim Myrow As Range
    Set Myrange = Selection
    For Each Myrow In Myrange.Rows
        '将奇数行突出显示
        If Myrow.Row Mod 2 = 1 Then
            Myrow.Interior.Color = vbCyan
        End If
    Next Myrow
End Sub
'注意，代码中指定了颜色为vbCyan（也可以修改成：vbRed, vbGreen, vbBlue）。

'13--突出显示拼错单词的单元格
'Excel没有像在Word或PowerPoint中那样进行拼写检查。虽然可以按F7键进行拼写检查，但当出现拼写错误时，没有视觉提示。
'使用此代码可以立即突出显示其中有拼写错误的所有单元格。

Sub HighlightMisspelledCells()
    Dim cl As Range
    For Each cl In ActiveSheet.UsedRange
        If Not Application.CheckSpelling(word:=cl.Text) Then
            cl.Interior.Color = vbRed
        End If
    Next cl
End Sub
'请注意，突出显示的单元格包含Excel认为是拼写错误的文本。当然在许多情况下，它也会显示其它各种错误。

 

'14--刷新工作簿中的所有透视表
'如果工作簿中有多个透视表，则可以使用此代码一次刷新所有这些透视表。

Sub RefreshAllPivotTables()
    Dim PT As PivotTable
    For Each PT In ActiveSheet.PivotTables
        PT.RefreshTable
    Next PT
End Sub

'15--将所选单元格的字母大小写改为大写
'虽然Excel有更改文本字母大小写的公式，但它使您可以在另一组单元格中进行更改。
'使用此代码可以立即更改所选文本中文本的字母大小写?

Sub ChangeCase()
    Dim rng As Range
    For Each rng In Selection.Cells
        If rng.HasFormula = False Then
            rng.Value = UCase(rng.Value)
        End If
    Next rng
End Sub
'注意，在本例中，使用了UCase将文本大小写设为大写。

'16--突出显示有批注的单元格
'使用下面的代码突出显示其中包含注释的所有单元格。

Sub HighlightCellsWithComments()
    ActiveSheet.Cells.SpecialCells(xlCellTypeComments).Interior.Color = vbBlue
End Sub
'在本例中，使用vblue为单元格赋予蓝色。如果你想的话，你可以把这个换成其他颜色。

'17--将所有公式转换为值
'如果工作表包含大量公式，并且要将这些公式转换为值，请使用此代码。

Sub ConvertToValues()
    With ActiveSheet.UsedRange
    .Value = .Value
    End With
End Sub
'此代码可以自动将使用公式的值转换为值。

'18--有公式的单元格锁定
'当您有大量的计算并且不想意外的删除或更改时，您可能希望使用把有公式的单元格进行锁定。
'下面是将锁定所有具有公式的单元格的代码，而所有其它单元格都未锁定。

Sub LockCellsWithFormulas()
    With ActiveSheet
        .Unprotect
        .Cells.Locked = False
        .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
        .Protect AllowDeletingRows:=True
    End With
End Sub

'19--保护工作簿中所有的工作表(不带密码保护)
'使用以下代码一次性保护工作簿中的所有工作表

Sub ProtectAllSheets2()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Protect
    Next ws
End Sub
'此代码将逐个浏览所有工作表并对其进行保护。
'如果要取消所有工作表的保护，可以使用 ws.unProtect。

'20--在所选内容中每隔一行后插入一行
'如果要在选定区域中的每一行后插入空行，请使用此代码。

Sub InsertAlternateRows()
    Dim rng As Range
    Dim CountRow As Integer
    Dim i As Integer
    Set rng = Selection
    CountRow = rng.EntireRow.count
    For i = 1 To CountRow
        ActiveCell.EntireRow.Insert
        ActiveCell.Offset(2, 0).Select
    Next i
End Sub
'同样，您可以修改此代码，以便在所选范围内的每一列之后插入一个空白列

'21--自动在相邻单元格中插入日期和时间戳
'当您想要跟踪活动时，可以使用时间戳。
'使用此代码在创建条目或编辑现有内容时在相邻单元格中插入日期和时间戳。

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Handler
    If Target.Column = 1 And Target.Value <> "" Then
        Application.EnableEvents = False
        Target.Offset(0, 1) = Format(Now(), "dd-mm-yyyy hh:mm:ss")
        Application.EnableEvents = True
    End If
Handler:
End Sub
'请注意，您需要将此代码插入工作表代码窗口（而不是模块内代码窗口）。因为这是一个事件代码

'22--显示所有隐藏的行和列
'下面的代码，可以取消所有隐藏的行和列。
'如果你从别人那里获得一个Excel文件，并希望没有隐藏的行与列，那么下面的代码对你非常有用。

Sub UnhideRowsColumns()
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False
End Sub

'23--取消所有的合并单元格
'如果你的工作表里面有合并的单元格，使用下面代码可以一次性取消所有合并的单元格。

Sub UnmergeAllCells()
    ActiveSheet.Cells.UnMerge
End Sub

 

'24--保存带有时间戳的工作簿
'很多时候，您可能需要创建工作的各个版本。
'一个好的做法，就是在工作薄名称上，加上时间戳。
'使用时间戳将允许您返回到某个文件，查看进行了哪些更改或使用了哪些数据。
'
'下面的代码会自动保存工作簿在指定的文件夹中 , 并添加一个时间戳时保存。

Sub SaveWorkbookWithTimeStamp()
    Dim timestamp As String
    timestamp = Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh-ss")
    ThisWorkbook.SaveAs "C:\Users\Username\Desktop\WorkbookName" & timestamp
End Sub

'25--将工作表另存为一个PDF文件
'如果您使用不同年份或部门或产品的数据，可能需要将不同的工作表保存为PDF文件。
'如果手动完成，这可能是一个耗时的过程，但vba确可以加快速度。
'
'下面是一个将每个工作表保存为单独PDF的VBA代码:

Sub SaveWorkshetAsPDF()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.ExportAsFixedFormat xlTypePDF, "C:\Users\Username\Desktop\Test\" & ws.Name & ".pdf"
    Next ws
End Sub
'请注意，此代码仅适用于工作表,并且需要在工作表里面设置好打印的区域。如果有空的工作表，那么程序会报错

'26--将工作簿另存为单独的PDF文件
'下面是将整个工作簿保存为指定文件夹中的PDF格式的代码

Sub save_WorkshetAsPDF()
    ThisWorkbook.ExportAsFixedFormat xlTypePDF, "C:UsersSumitDesktopTest" & ThisWorkbook.Name & ".pdf"
End Sub
'注意：25,26代码保存为PDF文件，需要在工作表里面设置好打印的区域。如果有空的工作表，那么程序会报错。

'27--突出显示所选数据集中的空白单元格
'虽然可以使用条件格式或“转到特殊”对话框突出显示空白单元格，但如果必须经常这样做，最好使用宏。
'创建后，你可以将代码保存在个人宏工作簿中。

Sub HighlightBlankCells()
    Dim Dataset As Range
    Set Dataset = Selection
    Dataset.SpecialCells(xlCellTypeBlanks).Interior.Color = vbRed
End Sub
'在这个代码中，指定了红色单元格中要突出显示的空白单元格。

'28--按单列对数据排序
'可以使用下面的代码按指定列对数据排序。

Sub SortDataHeader()
    Range("DataRange").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
End Sub
'请注意，我创建了一个名为“datarange”的命名范围，并使用它来代替单元格引用。
'这里还使用了三个关键参数: 参照之前的文章

'29--按多列对数据排序
'下面是将根据多个列对数据排序的代码（A列先排序，在进行B列排序）。

Sub SortMultipleColumns()
    With ActiveSheet.Sort
     .SortFields.Add Key:=Range("A1"), Order:=xlAscending
     .SortFields.Add Key:=Range("B1"), Order:=xlAscending
     .SetRange Range("A1:C13")
     .Header = xlYes.Apply
    End With
End Sub
'注意，这个代码指定了首先根据A列排序，然后根据B列排序

'30--如何只从字符串中获取数字部分
'如果只从字符串中提取数字部分或文本部分，则可以在VBA中创建自定义函数.
'然后，您可以在工作表中使用这个vba函数（就像普通的Excel函数一样），它将只从字符串中提取数字或文本部分.

'下面是将创建函数从字符串中提取数字部分的VBA代码:

Function GetNumeric(CellRef As String)
    Dim StringLength As Integer
    StringLength = Len(CellRef)
    For i = 1 To StringLength
        If IsNumeric(Mid(CellRef, i, 1)) Then
            Result = Result & Mid(CellRef, i, 1)
        End If
    Next i
    GetNumeric = Result
End Function
'您需要将代码放入模块中，然后可以在工作表中使用函数"=GetNumeric".
'此函数只接受一个参数，即要从中获取数值部分的单元格的单元格引用。

'31--总是在激活特定选项卡的情况下打开工作簿
'如果要打开一个工作簿，该工作簿总是在特定工作表的情况下打开，则可以使用以下代码。
'当您希望在工作簿打开时激活指定工作表时，这将非常有用。

Private Sub Workbook_Open()
    Sheets("Sheet1").Select
End Sub
'请注意，此代码需要放在ThisWorkbook对象的“代码”窗口中
'这意味着当您在VB编辑器中时，需要双击此工作簿对象并复制粘贴其中的代码。

'32--根据文件全路径名取文件名：
'InStr 返回一个字符串在另一个字符串中出现的位置。
'InStrRev 返回一个字符串在另一个字符串中出现的位置，从字符串末尾算起。

'Check if the Directory exists or not
'Parameter:in_DirectoryName
'return :verifyDirectoryExist

Function verifyDirectoryExist(in_DirectoryName As String)
    Dim bln_rtValue As Boolean 'the result of Directory is exist or not
    Dim str_fileName As String 'the file name
    Dim str_filepath As String 'the file path
       
    If Dir(in_DirectoryName) <> "" Then
        str_fileName = Dir(in_DirectoryName)
    Else
        str_fileName = Mid(in_DirectoryName, InStrRev(in_DirectoryName, "\") + 1)   '根据文件全路径名找文件名字。
    End If
    str_filepath = Replace(in_DirectoryName, str_fileName, "")
   
    If Dir(str_filepath, 16) <> Empty Then   '验证路径是否存在
        bln_rtValue = True
    Else
        bln_rtValue = False
    End If
    verifyDirectoryExist = bln_rtValue
End Function

'33--获取文件名的后缀名 instrrev()函数的使用
Sub test()
    Dim str As String
    Dim str_tz As String
    str = "ab.cdef.csv"
   
    str_tz = VBA.Right(str, Len(str) - InStrRev(str, "."))
    Debug.Print Len(str)  ' 11
    Debug.Print InStrRev(str, ".")  ' 8
    Debug.Print str_tz
    Debug.Print InStr(str, ".")  ' 3
End Sub

'34--清空某列：
Sub clearcontents()
    ThisWorkbook.Sheets(1).Range("F2:F65535").clearcontents '清空F列
    ThisWorkbook.Sheets(1).Range("F2:F65535").Font.Color = vbBlack  '设置某列字体为黑色
End Sub

'35--获取数据起始行
'get start_row of data in specified column in specified sheet.
'eg: the header's row  in B column is 5, generally the data start_row is 5+1=6.
'arguments: worksheet,column,header_name.
'added by collin 2019-09-10.
'本例可以使用find()函数重写，速度更快。
Function getDataStartRow(in_ws As Worksheet, in_col As String, in_header As String)
    Dim rng As Range
    Dim usedrow As Long
    usedrow = getLastValidRow(in_ws, in_col)
    getDataStartRow = 0
   
    For Each rng In in_ws.Range(in_col & 1, in_col & usedrow)
        If unifiedFormat(rng.Value) = unifiedFormat(in_header) Then
            getDataStartRow = rng.Row + 1
            Exit Function
        End If
    Next
   
    getDataStartRow = 0
End Function
'36--获取某列的最后一行（有数据的最后一行）
'Get last row of Column N in a Worksheet
Function getLastValidRow(in_ws As Worksheet, in_col As String)
    getLastValidRow = in_ws.Cells(in_ws.Rows.count, in_col).End(xlUp).Row
End Function
'37--格式化字符串
Function unifiedFormat(in_str As String)
    Dim str As String
    str = in_str
    str = UCase(str)
    str = Replace(str, " ", "")
    str = Replace(str, Chr(10), "") 'remove change line
    str = Replace(str, "_", "")
    str = Replace(str, "-", "")
    str = Replace(str, "–", "")
    str = Replace(str, ";", "")
    str = Replace(str, "(", "")
    str = Replace(str, ")", "")
    str = Replace(str, "%", "")
    str = Replace(str, ".", "")
    str = Replace(str, "/", "")
    unifiedFormat = str
End Function

'38--利用字典对指定列去重（不改变原列，将去重后的值存入到字典的keys中）
'get unique value from Duplicate Values in specified sheet and column,and save those unique values into Arrary.
'argus: worksheet, column, header, arrary(which must be defined as variant styte before passing it into this function)
Function saveUniqueValueIntoArrFromDuplicateValues(in_ws As Worksheet, in_col As String, in_header As String, ByRef in_arr_variant As Variant)
    Dim d As Object
    Dim i As Long
    Dim s As String
    Dim usedrow As Long
    Dim rng As Range
    Dim int_startrow As Integer
   
    int_startrow = getDataStartRow(in_ws, in_col, in_header)
    usedrow = getLastValidRow(in_ws, in_col)
   
    Set dic = CreateObject("scripting.dictionary")
   
    For Each rng In in_ws.Range(in_col & int_startrow, in_col & usedrow)
        s = rng.Value
        If Not d.Exists(s) Then
            dic(s) = ""     '设字典的value 为""
        End If
    Next rng
    in_arr_variant = dic.keys
End Function

Sub test2()
    Dim ar As Variant
    'Dim ar(1 To 14) As String
   
    'For i = 1 To 14
    '  arr(i) = ThisWorkbook.Worksheets(2).Range("A" & i).Value
    'Next i
    Call saveUniqueValueIntoArrFromDuplicateValues(ThisWorkbook.Worksheets(2), "A", "header", ar)
    ThisWorkbook.Worksheets(2).Range("B1:B" & UBound(ar) + 1) = Application.WorksheetFunction.Transpose(ar)

End Sub

Sub test3()
    Dim rng As Range
   
    For Each rng In ThisWorkbook.Worksheets(2).Range("D1:D14")
        Debug.Print rng
    Next

End Sub

'39--数字转列号字母
'Convert number to column
Function convertnumbertocolumn(ByVal num As Long) As String
    convertnumbertocolumn = Replace(Cells(1, num).Address(False, False), "1", "")
End Function

'40--列号字母转数字
'Convert column to number
Function convertcolumntonumber(ByVal col As String) As Long
    convertcolumntonumber = Range("a1:" & col & "1").Cells.count
End Function

'41--筛选和筛选后复制
'使用aupayroll tax里的一段代码示例：完整代码请找aupayroll tax parm file.
Sub PreApro11()

        If ws_apro_input.AutoFilterMode = True Then
            ws_apro_input.AutoFilterMode = False
        End If
        ws_apro_input.Range("$A$3:$AF$" & int_last_row_input).AutoFilter Field:=2, Criteria1:=str_filter, Operator:=xlFilterValues
       
        'use range.SpecialCells(xlCellTypeVisible).Copy to copy filtered range.
        ws_apro_input.Range("A1:AF" & int_last_row_input).SpecialCells(xlCellTypeVisible).Copy ws_new_apro.Range("A1")
       
        ws_new_apro.Cells.WrapText = False
        ws_new_apro.Columns("A:AF").AutoFit
       
        ws_new_apro.Name = ws_apro_input.Name
        If verifyFileExist(get_F30_Apro_Filter_File) Then
            Kill get_F30_Apro_Filter_File
        End If
        wb_new_apro.SaveAs Filename:=get_F30_Apro_Filter_File
       
        closeF2_Apro_File False
        wb_new_apro.Close savechanges:=True
    End If

End Sub

'42-1-将指定两列分别作为Key和Value添加到字典中
'this funtion is designed to add AwardType and RSUorSO in 'Misc_Config' sheet to dictionary.
'key: AwardType
'value: RSUorSO
Private Function addAwardType_RSUorSOToDictionary()

    Dim ws_misc             As Worksheet
    Dim index               As Integer
    Dim str_awardType       As String
    Dim str_RSUorSO         As String
   
    Set dic_awardType_RSUorSO = CreateObject("Scripting.Dictionary")
    Set ws_misc = ThisWorkbook.Sheets(STR_Sheet_Misc_Config)
   
    For index = 3 To getLastValidRow(ws_misc, "J")        '从第3行开始是有效数据
   
        str_awardType = VBA.Trim(ws_misc.Range("J" & index))  'key
        str_RSUorSO = VBA.Trim(ws_misc.Range("K" & index))    'value
   
        If Not dic_awardType_RSUorSO.Exists(str_awardType) Then     '判断key是否已经存在,不存在才添加
            dic_awardType_RSUorSO.Add str_awardType, str_RSUorSO
        End If
   
    Next index
End Function
'42-2-将指定三列的一列作为Key和两外两列作为Value添加到字典中
Private Function addIT0001ToDictionary()

    Dim ws_it0001           As Worksheet
    Dim index_it0001        As Long
    Dim arr()
   
    Dim str_global_id       As String
    Dim str_company_code    As String
    Dim str_Personnel_Area  As String
   
    openF20_IT0001_Report
    Set ws_it0001 = wb_F20_IT0001_Report.Sheets(1)
   
    Set dic_it0001 = CreateObject("Scripting.Dictionary")

    For index_it0001 = 2 To getLastValidRow(ws_it0001, F20_Col_IBMCNUM)
       
        str_global_id = add0IfEELess9(VBA.Trim(ws_it0001.Range(F20_Col_IBMCNUM & index_it0001)))  'key
        str_company_code = VBA.Trim(ws_it0001.Range(F20_Col_CompanyCode & index_it0001))          'value 数组的第一个元素
        str_Personnel_Area = VBA.Trim(ws_it0001.Range(F20_Col_PersonnelArea & index_it0001))      'value 数组的第二个元素
       
        If str_global_id <> "" And Not dic_it0001.Exists(str_global_id) Then
            arr = Array(str_company_code, str_Personnel_Area)                    '使用Array(元素1,元素2,...) 函数定义数组
            dic_it0001.Add str_global_id, arr
        End If

           
    Next index_it0001
   
End Function

'43--loop files in specified folder
'this function is designed to judge whether those files in workercomp folder could be calculated or not.if any file couldn't be calculated,returns false.

Private Function isAllFilesCalculable() As Boolean

    Dim str_targetfilename                                As String
    Dim str_targetfilefullname                            As String
    Dim wsht                                              As Worksheet
    Dim rng                                               As Range
    Dim usedrows                                          As Byte
    Dim str_thefirstcnum                                  As String
    Dim bo_headerinsheet                                  As Boolean
    Dim bo_snconsistent                                   As Boolean

    My_Err = "WorkersCompCalculation module error - isAllFilesCalculable function error."
   
    bo_snconsistent = True
    isAllFilesCalculable = True
    bo_headerinsheet = False
    long_calculablefilecount = 0
   
    str_reportingmonthinparm = unifiedFormat("Reporting Month" & ThisWorkbook.Worksheets(STR_AU_PayrollTax_Parm).Range(Col_AU_PayrollTax_Parm_Value & 3) & "/" & ThisWorkbook.Worksheets(STR_AU_PayrollTax_Parm).Range(Col_AU_PayrollTax_Parm_Value & 4))
   
    '1--Useing  'Do...Loop'  to make sure there are no uncalculable files in this folder, if any(any file's ,any erroType),exit function and  return isAllFilesCalculable False.
    'it is no need to judge wether there are files in this folder,cause the judgement has been done in 'Invalidate' part.
    On Error GoTo 0
    str_targetfilename = Dir(get_F14_Worker_Comp_Folder() & "*.xlsx")
   
    Do
       boolean_calculateFlag = False
       str_thefirstcnum = "null"
       str_targetfilefullname = get_F14_Worker_Comp_Folder() & str_targetfilename
       Set wb_workercomp = checkAndAttachWorkbook(str_targetfilefullname)
      
       'restore the  arr_reportmonthsheets() after circle of  one file.This array is used to store reportMonthSheet's name, and the function 'updateErrorDetails' will use it,when the error message relevent to those sheets.
       byte_reportmonthsheetscount = 0
       ReDim arr_reportmonthsheets(1 To byte_reportmonthsheetscount + 1)
       
       For Each wsht In wb_workercomp.Worksheets
            '2--get the reportingMonth of this worksheet, if "Reporting Month"exist,give it's value to reportingMonth ,otherwise reportingMonth equals to "".
            str_reportingmonth = "null"
            str_cnum = "null"
            usedrows = wsht.Range("A" & Rows.count).End(xlUp).Row
            For Each rng In wsht.Range("A1", "A" & usedrows)
                If unifiedFormat(rng.Value) Like unifiedFormat("Reporting Month*") Then
                    str_reportingmonth = unifiedFormat(rng.Value)
                    Exit For
                End If
            Next rng
           
            'step 3--if reportingMonth in this worksheet matches the str_reportingmonthinparm, then judge cnum and header
            'step 4--judge whether the CNUM exist and be consistent with all reporting month sheets in this workbook.
            If str_reportingmonth = str_reportingmonthinparm Then
                'if reportingMonth = str_reportingmonthinparm ,then add this worksheet's name to arry, the function 'updateErrorDetails' will use it,when the cnums are inconsistent with each other.
                byte_reportmonthsheetscount = byte_reportmonthsheetscount + 1
                ReDim Preserve arr_reportmonthsheets(1 To byte_reportmonthsheetscount)
                arr_reportmonthsheets(byte_reportmonthsheetscount) = wsht.Name
               
                'get cnum in this reporting month sheet.
                For Each rng In wsht.Range("A1", "A" & usedrows)
                    If Left(unifiedFormat(rng.Value), 2) = "SN" Then
                        str_cnum = add0IfEELess9(LTrim(Right(Trim(wsht.Range("A2").Value), Len(Trim(wsht.Range("A2").Value)) - 2)))
                        If str_thefirstcnum = "null" Then
                            str_thefirstcnum = str_cnum
                        End If
                        Exit For
                    End If
                Next rng
                'if the cnum still equls to "", feedback error message to control report,and skip.
                If str_cnum = "null" Then
                    isAllFilesCalculable = False
                    Set ws_workercomp = wsht
                    str_errorType = "no cnum found in reporting month sheet"
                    Call updateErrorDetails
                    Exit Function
                End If
                    'note: use else and if respectively not elseif ,they are definite defierent!
                If str_cnum <> str_thefirstcnum Then
                    str_errorType = "CNUM is not consistent in reporting month sheets"
                    Call updateErrorDetails
                    isAllFilesCalculable = False
                    Exit Function
                End If
       
               ' step 5--if ReportMonthMatched and cnum is ok, then judge the header (whether the header in reporting month sheet match the header in 'Input_Header_Config' sheet of parm file).
               bo_headerinsheet = isHeaderInWorkerComp(wsht)
               If bo_headerinsheet Then  'it means the current reporting month sheets is calculable, so add it to arr_calculablefiles.
                    boolean_calculateFlag = True 'it means the current file has at least one matched reporting month sheet and it's header,cnum are ok. the current file is calculable.
                Else
                    isAllFilesCalculable = False
                    Set ws_workercomp = wsht
                    str_errorType = "no matched header in sheet"
                    Call updateErrorDetails
                    Exit Function
               End If
          End If
       Next wsht
    
       If boolean_calculateFlag Then
           long_calculablefilecount = long_calculablefilecount + 1
           ReDim Preserve arr_calculablefiles(1 To long_calculablefilecount) As String
           arr_calculablefiles(long_calculablefilecount) = str_targetfilefullname
       End If
        
      'step 6 if boolean_calculateFlag = False, it means that the current file is uncalculable,and there is no need to judge other files,return isAllFileCalculable false, exit this function, skip this part!
       If boolean_calculateFlag = False Then
            isAllFilesCalculable = False
            If str_reportingmonth <> str_reportingmonthinparm Then
                str_errorType = "no matched sheet in file"
                Call updateErrorDetails
            End If
            Exit Function
       End If
      
       wb_workercomp.Close savechanges:=False
       Set wb_workercomp = Nothing
       On Error GoTo 0
       str_targetfilename = Dir
       If str_targetfilename = "" Then
           Exit Function
       End If
    
   Loop
  
End Function

'44-1--使用一维数组对单元格赋值
'把1-2000的自然数写入到A1：A2000单元格里
Function input_test(in_ws As Worksheet)
    Dim i As Long
    Dim arr(1 To 2000) As Long                                                    '关键的语法:定义一维数组
    For i = 1 To 2000
      arr(i) = i
    Next
   
    in_ws.Range("A1:A2000").Value = Application.WorksheetFunction.Transpose(arr)  '关键的语法
       
End Function

'44-2--使用二维数组对单元格赋值
'把1-2000的自然数写入到A1：A2000单元格里
Function input_test2(in_ws As Worksheet)
    Dim i As Long
    Dim arr(1 To 2000, 1 To 1) As Long       '关键的语法:定义二维数组
    For i = 1 To 2000
      arr(i, 1) = i
    Next
   
    in_ws.Range("A1:A2000").Value = arr      '关键的语法
       
End Function

'45--使用find()函数来查找第一次出现的字符串，代替for each 循环
Function test_find(in_ws As Worksheet, in_str As String, in_setpath As String)
    '代码片段：
    Dim rng As Range
    Set rng = ws.Cells.Find(in_str, , , 1)
    rng.Offset(0, 1).Value = in_setpath
End Function

 

'46--获取环境变量的方式1 VBA.Environ(name)：
Private Function get_env()
   str_rpa_environment = VBA.Environ("RPA_ENVIRONMENT")
End Function

'47--读取环境变量的方法2--readUserEnv(name)
Function readUserEnv(in_name As String)
    Dim objUserEnvVars As Object
    Dim strVar As String
   
    Set objUserEnvVars = CreateObject("WScript.Shell").Environment("User")
    strVar = objUserEnvVars.Item(in_name)
'    Debug.Print strVar
    readUserEnv = strVar
End Function

'48--对合并了的单元格的查找
'Robot needs to base on reporting month in parm file, search AU payroll calendar by month column in “QM&QF Calendar” in parm file, to find all pay period in the month.
Private Function Validate_Payroll_Calendar(Col_Month As String, Col_PayPeriod As String, PayType As String) As Boolean
    Dim sht_PayrollCalendar                 As Worksheet
    Dim Calendar_Date                       As Date
    Dim Month_LastRow                       As Long
    Dim PayPeriod_LastRow                   As Long
    Dim index                               As Long
    Dim count                               As Long
    Dim Q_index                             As Long
    Dim Q_count                             As Long
    Dim PayPeriod                           As String
    Dim Calendar_PayPeriod                  As String
 
    My_Err = "ESPPCaliculation module error - Validate_Payroll_Calendar function error."
 
    Validate_Payroll_Calendar = True
    Calendar_PayPeriod = ""
    Set sht_PayrollCalendar = ThisWorkbook.Sheets(Sht_PayrollCalendar_Name)
    Month_LastRow = getLastValidRow(sht_PayrollCalendar, Col_Month)
    PayPeriod_LastRow = getLastValidRow(sht_PayrollCalendar, Col_PayPeriod)
    count = Application.Max(Month_LastRow, PayPeriod_LastRow)
    For index = 3 To count
        If Trim(sht_PayrollCalendar.Range(Col_Month & index)) <> "" Then
            Calendar_Date = CDate(Trim(sht_PayrollCalendar.Range(Col_Month & index)))
            If Year(Calendar_Date) = get_Reporting_Year And Month(Calendar_Date) = Val(get_Reporting_Month) Then   '根据reporting year & month 找对应的月的 QM QF 的period
                If sht_PayrollCalendar.Range(Col_Month & index).MergeCells Then   '如果日期的单元格合并了
                    'MergeArea.Rows.count 被合并的单元格的个数。比如第10行是一个合并单元格的开始行，公合并了3个单元格，那么 3+10-1=12，表示10，11，12行被合并
                    Q_count = sht_PayrollCalendar.Range(Col_Month & index).MergeArea.Rows.count + index - 1
                    For Q_index = index To Q_count '遍历 period列的10，11，12行
                        PayPeriod = Replace(sht_PayrollCalendar.Range(Col_PayPeriod & Q_index), " ", "")
                        If PayPeriod <> "" Then
                            If Calendar_PayPeriod <> "" Then
                                Calendar_PayPeriod = Calendar_PayPeriod & "/" & PayType & " " & PayPeriod '对于第一次 For Q_index循环：QM/PP04
                            Else
                                Calendar_PayPeriod = PayType & " " & PayPeriod   'Calendar_PayPeriod 最终能得到类似：QM PP04   或 QF PP07/QF PP08/QF PP09
                            End If
                        End If
                    Next Q_index
                    Exit For
                End If
            End If
        End If
    Next index
    If Calendar_PayPeriod = "" Then
        Validate_Payroll_Calendar = False
    End If
    If Calendar_PayPeriod_List <> "" Then
        'Calendar_PayPeriod_List 最终能得到类似：QM PP04/QF PP07/QF PP08/QF PP09（此function会先后调用两次：Validate_Payroll_Calendar("A","B","QM"),Validate_Payroll_Calendar("D","E","QF"))
        Calendar_PayPeriod_List = Calendar_PayPeriod_List & "/" & Calendar_PayPeriod
    Else
        Calendar_PayPeriod_List = Calendar_PayPeriod
    End If
  
End Function