'
' 30个有用的VBA代码
' 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--对合并了的单元格的查找
'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") & "秒。"
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
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
'此代码首先检查是否有任何已筛选的数据,否则，它会复制筛选后的数据，插入新工作簿，并将数据粘贴到其中。
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.
'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
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
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
'注意这个变化是不可逆的，公式将无法恢复。
'或者，你也可以编写一个消息框，显示公式将丢失的警告。这可以防止用户意外运行此宏
'如果要快速将所有具有公式的单元格转换为值，可以使用以下代码：
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。
'如果要查找表中的值并在同一单元格中获取所有匹配结果，则需要使用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 – 提取结果的列号
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
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
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
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
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
'需要注意的是，取消保护工作表的密码， 要与锁定工作表的密码相同，否则程序会抛出异常（出错）。
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）。
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认为是拼写错误的文本。当然在许多情况下，它也会显示其它各种错误。
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
Dim PT As PivotTable
For Each PT In ActiveSheet.PivotTables
PT.RefreshTable
Next PT
End Sub
'15--将所选单元格的字母大小写改为大写
'虽然Excel有更改文本字母大小写的公式，但它使您可以在另一组单元格中进行更改。
'使用此代码可以立即更改所选文本中文本的字母大小写?
'虽然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将文本大小写设为大写。
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为单元格赋予蓝色。如果你想的话，你可以把这个换成其他颜色。
ActiveSheet.Cells.SpecialCells(xlCellTypeComments).Interior.Color = vbBlue
End Sub
'在本例中，使用vblue为单元格赋予蓝色。如果你想的话，你可以把这个换成其他颜色。
'17--将所有公式转换为值
'如果工作表包含大量公式，并且要将这些公式转换为值，请使用此代码。
'如果工作表包含大量公式，并且要将这些公式转换为值，请使用此代码。
Sub ConvertToValues()
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub
'此代码可以自动将使用公式的值转换为值。
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
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。
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
'同样，您可以修改此代码，以便在所选范围内的每一列之后插入一个空白列
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
'请注意，您需要将此代码插入工作表代码窗口（而不是模块内代码窗口）。因为这是一个事件代码
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
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub
'23--取消所有的合并单元格
'如果你的工作表里面有合并的单元格，使用下面代码可以一次性取消所有合并的单元格。
Sub UnmergeAllCells()
ActiveSheet.Cells.UnMerge
End Sub
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:UsersUsernameDesktopWorkbookName" & timestamp
End Sub
Dim timestamp As String
timestamp = Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh-ss")
ThisWorkbook.SaveAs "C:UsersUsernameDesktopWorkbookName" & timestamp
End Sub
'25--将工作表另存为一个PDF文件
'如果您使用不同年份或部门或产品的数据，可能需要将不同的工作表保存为PDF文件。
'如果手动完成，这可能是一个耗时的过程，但vba确可以加快速度。
'
'下面是一个将每个工作表保存为单独PDF的VBA代码:
Sub SaveWorkshetAsPDF()
Dim ws As Worksheet
For Each ws In Worksheets
ws.ExportAsFixedFormat xlTypePDF, "C:UsersUsernameDesktopTest" & ws.Name & ".pdf"
Next ws
End Sub
'请注意，此代码仅适用于工作表,并且需要在工作表里面设置好打印的区域。如果有空的工作表，那么程序会报错
Dim ws As Worksheet
For Each ws In Worksheets
ws.ExportAsFixedFormat xlTypePDF, "C:UsersUsernameDesktopTest" & 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文件，需要在工作表里面设置好打印的区域。如果有空的工作表，那么程序会报错。
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
'在这个代码中，指定了红色单元格中要突出显示的空白单元格。
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”的命名范围，并使用它来代替单元格引用。
'这里还使用了三个关键参数: 参照之前的文章
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列排序
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".
'此函数只接受一个参数，即要从中获取数值部分的单元格的单元格引用。
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编辑器中时，需要双击此工作簿对象并复制粘贴其中的代码。
Sheets("Sheet1").Select
End Sub
'请注意，此代码需要放在ThisWorkbook对象的“代码”窗口中
'这意味着当您在VB编辑器中时，需要双击此工作簿对象并复制粘贴其中的代码。
'32--根据文件全路径名取文件名：
'InStr 返回一个字符串在另一个字符串中出现的位置。
'InStrRev 返回一个字符串在另一个字符串中出现的位置，从字符串末尾算起。
'Check if the Directory exists or not
'Parameter:in_DirectoryName
'return :verifyDirectoryExist
'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
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
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
'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)
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
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
'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
'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()
'使用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
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 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")
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
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
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
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
'把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
'把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
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
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
'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