vbscript 其他VBA - 来自：<script src =“https://gist.github.com/pudelosha/c997c6091fbb4103e5fe1dc21692
Posted
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了vbscript 其他VBA - 来自：<script src =“https://gist.github.com/pudelosha/c997c6091fbb4103e5fe1dc21692相关的知识，希望对你有一定的参考价值。
' ############################ FUNCTION / PROCEDURE LIST ############################
' ###################################################################################
'
' 1. ListNamedRanges
' The function lists all custom named ranges. It is possible to provide optional parameter so that the function checks if validated text string contains this value
' 2. ListPivotTableDataSources
' The procedures lists all pivot tables and their data sources
' 3. NamedRangeHeaders
' This function returns header names for particular named range
' 4. GetFilePath
' The function displays dialog box which allows the user to select a file. Eventually the funtions returns full path which leads to selected document.
' 5. ReplaceInArray
' Using this function you can replace text string in single/multi-dimension array
' 6. ReturnValueFromArray
' With this function the user can return value from single/multi-dimension array
' 7. SumArrays
' Sum the results from 3 same size arrays
' 8. GetColumnToArray
' This function puts the values from entire column into array
' 9. MultiplyArrays
' Multiply the results from 2 arrays
' 10. MultiplyArrayBy
' Multiply the array by multiplier value
' 11. DivideArrayBy
' Divide the array by provided value
' 12. CheckIfInArray
' Check if an array contains provided value
' 13. GetArrDimension
' Check if array is 1 or 2 dimension
' 14. ReplaceIfBlank
' Replace value if blank
' 15. CheckIfFolderExists
' The function returns true/false value depending on folder existance
' 16. CreateNewFolder
' The procedure creates a new folder in particular location
' 17. BoostPerformance
' The procedure improves calculation performance
' 18. CheckIfSheetExists
' The function verifies whether particular sheet can be found
' 19. FindLastRow
' The result of this function is the number of last row
' 20. FindNonBlankRow
' The function counts the number of non-blank records in particular column
' 21. CheckIfPivotExists
' This function check if pivot table exists
' 22. FindRowCol
' Multi purpose function that shows the number of row/column based on provided header/row name
' 23. ShowAllSheets
' The procedure reveals all sheets
' 24. AddNamedRange
' The procedure creates/updates named range
' 25.
'
Option Explicit
Enum RowCol
FindRow = 1
FindColumn = 2
End Enum
Function ListNamedRanges(Optional strPartialName As String) As Variant
Dim n As Name
Dim i As Integer
Dim varResult As Variant
ReDim varResult(0 To 0)
For Each n In ThisWorkbook.Names
If strPartialName <> "" Then
If n.Name Like "*" & strPartialName & "*" Then
ReDim Preserve varResult(1 To UBound(varResult) + 1)
varResult(UBound(varResult)) = n.Name
End If
Else
ReDim Preserve varResult(1 To UBound(varResult) + 1)
varResult(UBound(varResult)) = n.Name
End If
Next n
ListNamedRanges = varResult
End Function
Sub ListPivotTableDataSources()
Dim sht As Worksheet
Dim pvt As PivotTable
For Each sht In ThisWorkbook.Sheets
For Each pvt In sht.PivotTables
Debug.Print "Sheet: " & sht.Name & ", PivotTable: " & pvt.Name & ", Source: " & pvt.SourceData
Next pvt
Next sht
End Sub
Function NamedRangeHeaders(strRangeName As String) As Variant
Dim rngRange As Range
Dim i As Integer
Dim varResult As Variant
Set rngRange = Range(strRangeName)
ReDim varResult(1 To rngRange.Columns.Count)
For i = 1 To rngRange.Columns.Count
varResult(i) = rngRange.Value2(1, i)
Next i
NamedRangeHeaders = varResult
Set rngRange = Nothing
End Function
Function GetFilePath(strTitle As String) As String
Dim FD As FileDialog
Dim strItem As String
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Title = strTitle
.AllowMultiSelect = False
.InitialFileName = ActiveWorkbook.Path & "\"
If .Show <> -1 Then GoTo NextCode
strItem = .SelectedItems(1)
End With
NextCode:
GetFilePath = strItem
Set FD = Nothing
End Function
Function ReplaceInArray(varArr As Variant, strLookUpValue As String, strReplacement As String) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr) Then ReplaceInArray = "Provided parameter is not an array": Exit Function
Select Case GetArrDimension(varArr)
Case 1
If UBound(varArr, 1) <> UBound(varArr, 1) Then ReplaceInArray = False: Exit Function
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
For i = lngLBound1D To lngUBound1D
varArr(i) = Replace(CStr(varArr(i)), strLookUpValue, strReplacement, , , vbTextCompare)
Next i
ReplaceInArray = varArr
Case 2
If UBound(varArr, 1) <> UBound(varArr, 1) Then ReplaceInArray = False: Exit Function
If UBound(varArr, 1) <> UBound(varArr, 1) Then ReplaceInArray = False: Exit Function
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
lngLBound2D = LBound(varArr, 2)
lngUBound2D = UBound(varArr, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
varArr(i, j) = Replace(CStr(varArr(i, j)), strLookUpValue, strReplacement, , , vbTextCompare)
Next j
Next i
ReplaceInArray = varArr
Case Else
ReplaceInArray = False: Exit Function
End Select
End Function
Function ReturnValueFromArray(varArr As Variant, strLookUpValue As String, intLookUpCol As Integer, intReturnCol As Integer) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim i As Long
If Not IsArray(varArr) Then ReturnValueFromArray = "Provided parameter is not an array": Exit Function
Select Case GetArrDimension(varArr)
Case 1
ReturnValueFromArray = "Provided array variable must have 2 dimensions!"
Case 2
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
For i = lngLBound1D To lngUBound1D
If CStr(varArr(i, intLookUpCol)) = CStr(strLookUpValue) Then ReturnValueFromArray = varArr(i, intReturnCol): Exit Function
Next i
ReturnValueFromArray = "No Match Found!"
Case Else
ReturnValueFromArray = "Provided array variable must have 2 dimensions!"
End Select
End Function
Function ReturnValueFromArrayInStr(varArr As Variant, strLookUpValue As String, intLookUpCol As Integer, intReturnCol As Integer) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim i As Long
If Not IsArray(varArr) Then ReturnValueFromArrayInStr = "Provided parameter is not an array": Exit Function
Select Case GetArrDimension(varArr)
Case 1
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
For i = lngLBound1D To lngUBound1D
If InStr(1, CStr(UCase(varArr(i))), UCase(strLookUpValue), vbTextCompare) > 0 Then ReturnValueFromArrayInStr = varArr(i): Exit Function
Next i
ReturnValueFromArrayInStr = "No Match Found!"
Case 2
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
For i = lngLBound1D To lngUBound1D
If InStr(1, CStr(UCase(varArr(i, intLookUpCol))), UCase(strLookUpValue), vbTextCompare) > 0 Then ReturnValueFromArrayInStr = varArr(i, intReturnCol): Exit Function
Next i
ReturnValueFromArrayInStr = "No Match Found!"
Case Else
ReturnValueFromArrayInStr = "Provided array variable must have 2 dimensions!"
End Select
End Function
Function SumArrays(varArr1 As Variant, varArr2 As Variant, varArr3 As Variant) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr1) Then SumArrays = False: Exit Function
If Not IsArray(varArr2) Then SumArrays = False: Exit Function
If Not IsArray(varArr3) Then SumArrays = False: Exit Function
If GetArrDimension(varArr1) <> GetArrDimension(varArr2) Then SumArrays = False: Exit Function
If GetArrDimension(varArr1) <> GetArrDimension(varArr3) Then SumArrays = False: Exit Function
Select Case GetArrDimension(varArr1)
Case 1
If UBound(varArr1, 1) <> UBound(varArr2, 1) Then SumArrays = False: Exit Function
If UBound(varArr1, 1) <> UBound(varArr3, 1) Then SumArrays = False: Exit Function
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
For i = lngLBound1D To lngUBound1D
varArr1(i) = varArr1(i) + varArr2(i) + varArr3(i)
Next i
SumArrays = varArr1
Case 2
If UBound(varArr1, 1) <> UBound(varArr2, 1) Then SumArrays = False: Exit Function
If UBound(varArr1, 1) <> UBound(varArr3, 1) Then SumArrays = False: Exit Function
If UBound(varArr1, 2) <> UBound(varArr2, 2) Then SumArrays = False: Exit Function
If UBound(varArr1, 2) <> UBound(varArr3, 2) Then SumArrays = False: Exit Function
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
lngLBound2D = LBound(varArr1, 2)
lngUBound2D = UBound(varArr1, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
varArr1(i, j) = varArr1(i, j) + varArr2(i, j) + varArr3(i, j)
Next j
Next i
SumArrays = varArr1
Case Else
SumArrays = False: Exit Function
End Select
End Function
Function GetColumnToArray(sht As Worksheet, strHeaderName As String, intHeaderRow As Integer, lngRawDataRecordCount As Long) As Variant
Dim intCol As Integer
With sht
intCol = modUtils.FindRowCol(strHeaderName, .Range(.Cells(intHeaderRow, 1), .Cells(intHeaderRow, WorksheetFunction.CountA(.Rows(intHeaderRow)))), 2)
If intCol <> 0 Then
GetColumnToArray = .Range(.Cells(intHeaderRow + 1, intCol), .Cells(lngRawDataRecordCount, intCol)).Value
Exit Function
End If
End With
End Function
Function MultiplyArrays(varArr1 As Variant, varArr2 As Variant) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr1) Then MultiplyArrays = False: Exit Function
If Not IsArray(varArr2) Then MultiplyArrays = False: Exit Function
If GetArrDimension(varArr1) <> GetArrDimension(varArr2) Then MultiplyArrays = False: Exit Function
Select Case GetArrDimension(varArr1)
Case 1
If UBound(varArr1, 1) <> UBound(varArr2, 1) Then MultiplyArrays = False: Exit Function
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
For i = lngLBound1D To lngUBound1D
varArr1(i) = varArr1(i) * varArr2(i)
Next i
MultiplyArrays = varArr1
Case 2
If UBound(varArr1, 1) <> UBound(varArr2, 1) Then MultiplyArrays = False: Exit Function
If UBound(varArr1, 2) <> UBound(varArr2, 2) Then MultiplyArrays = False: Exit Function
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
lngLBound2D = LBound(varArr1, 2)
lngUBound2D = UBound(varArr1, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
varArr1(i, j) = varArr1(i, j) * varArr2(i, j)
Next j
Next i
MultiplyArrays = varArr1
Case Else
MultiplyArrays = False: Exit Function
End Select
End Function
Function MultiplyArrayBy(varArr1 As Variant, dblMultiplier As Double) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr1) Then MultiplyArrayBy = False: Exit Function
Select Case GetArrDimension(varArr1)
Case 1
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
For i = lngLBound1D To lngUBound1D
varArr1(i) = varArr1(i) * dblMultiplier
Next i
MultiplyArrayBy = varArr1
Case 2
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
lngLBound2D = LBound(varArr1, 2)
lngUBound2D = UBound(varArr1, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
varArr1(i, j) = varArr1(i, j) * dblMultiplier
Next j
Next i
MultiplyArrayBy = varArr1
Case Else
MultiplyArrayBy = False: Exit Function
End Select
End Function
Function DivideArrayBy(varArr1 As Variant, dblMultiplier As Double) As Variant
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr1) Then DivideArrayBy = False: Exit Function
Select Case GetArrDimension(varArr1)
Case 1
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
For i = lngLBound1D To lngUBound1D
varArr1(i) = varArr1(i) / dblMultiplier
Next i
DivideArrayBy = varArr1
Case 2
lngLBound1D = LBound(varArr1, 1)
lngUBound1D = UBound(varArr1, 1)
lngLBound2D = LBound(varArr1, 2)
lngUBound2D = UBound(varArr1, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
On Error Resume Next
varArr1(i, j) = varArr1(i, j) / dblMultiplier
If Err.Number <> 0 Then varArr1(i, j) = 0
On Error GoTo 0
Next j
Next i
DivideArrayBy = varArr1
Case Else
DivideArrayBy = False: Exit Function
End Select
End Function
Function CheckIfInArray(varArr As Variant, strLookUpValue As String) As Boolean
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr) Then CheckIfInArray = False: Exit Function
Select Case GetArrDimension(varArr)
Case 1
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
For i = lngLBound1D To lngUBound1D
If CStr(varArr(i)) = CStr(strLookUpValue) Then CheckIfInArray = True: Exit Function
Next i
Case 2
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
lngLBound2D = LBound(varArr, 2)
lngUBound2D = UBound(varArr, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
If CStr(varArr(i, j)) = CStr(strLookUpValue) Then CheckIfInArray = True: Exit Function
Next j
Next i
Case Else
CheckIfInArray = False: Exit Function
End Select
End Function
Function CheckIfInArrayInStr(varArr As Variant, strLookUpValue As String) As Boolean
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
If Not IsArray(varArr) Then CheckIfInArrayInStr = False: Exit Function
Select Case GetArrDimension(varArr)
Case 1
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
For i = lngLBound1D To lngUBound1D
If InStr(1, CStr(UCase(varArr(i))), UCase(strLookUpValue), vbTextCompare) > 0 Then CheckIfInArrayInStr = True: Exit Function
Next i
Case 2
lngLBound1D = LBound(varArr, 1)
lngUBound1D = UBound(varArr, 1)
lngLBound2D = LBound(varArr, 2)
lngUBound2D = UBound(varArr, 2)
For i = lngLBound1D To lngUBound1D
For j = lngLBound2D To lngUBound2D
If InStr(1, CStr(UCase(varArr(i, j))), UCase(strLookUpValue), vbTextCompare) > 0 Then CheckIfInArrayInStr = True: Exit Function
Next j
Next i
Case Else
CheckIfInArrayInStr = False: Exit Function
End Select
End Function
Function GetArrDimension(varArr As Variant) As Integer
Dim i As Integer
Dim j As Integer
On Error GoTo ErrHandler:
i = 0
Do While True
i = i + 1
j = UBound(varArr, i)
Loop
ErrHandler:
GetArrDimension = i - 1
End Function
Function ReplaceIfBlank(varValue As Variant, strReplacement) As String
If varValue = "" Or IsNull(varValue) Then
ReplaceIfBlank = strReplacement
Else
ReplaceIfBlank = varValue
End If
End Function
Function CheckIfFolderExists(strPath As String) As Boolean
CheckIfFolderExists = True 'path exists by default
If Len(Dir(strPath, vbDirectory)) = 0 Then
CheckIfFolderExists = False
End If
End Function
Sub CreateNewFolder(strPath As String)
On Error Resume Next
MkDir strPath
If Err.Number <> 0 Then
MsgBox "The folder " & strPath & " could not be created!"
Err.Clear
End If
On Error GoTo 0
End Sub
Sub BoostPerformance(blnActivate As Boolean)
Select Case blnActivate
Case True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Case False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Select
End Sub
Function CheckIfSheetExists(strSheetName As String) As Boolean
Dim shtTemp As Worksheet
CheckIfSheetExists = True
On Error Resume Next
Set shtTemp = ThisWorkbook.Sheets(strSheetName)
If shtTemp Is Nothing Then
MsgBox "The sheet " & strSheetName & " does not exist!", vbCritical, "Sheet not found"
CheckIfSheetExists = False
End If
On Error GoTo 0
End Function
Function FindLastRow(sht As Worksheet, intColToCheck) As Long
FindLastRow = sht.Cells(sht.Rows.Count, intColToCheck).End(xlUp).Row
End Function
Function FindNonBlankRow(sht As Worksheet, intColToCheck) As Long
FindNonBlankRow = WorksheetFunction.CountA(sht.Columns(intColToCheck))
End Function
Function CheckIfPivotExists(strSheetName As String, strPivotName As String) As Boolean
Dim pvtTemp As PivotTable
CheckIfPivotExists = False
On Error Resume Next
Set pvtTemp = ThisWorkbook.Sheets(strSheetName).PivotTables(strPivotName)
If pvtTemp Is Nothing Then
MsgBox "The pivot table " & strPivotName & " does not exist!", vbCritical, "Pivot Table not found"
CheckIfPivotExists = False
End If
On Error GoTo 0
End Function
Function FindRowCol(strSearchVal As String, rngToSearch As Range, rcColRow As RowCol, Optional rngAfterCell As Range) As Long
If Not rngAfterCell Is Nothing Then
Select Case rcColRow
Case 1
On Error Resume Next
FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=xlWhole, After:=rngAfterCell).Row
On Error GoTo 0
Case 2
On Error Resume Next
FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=xlWhole, After:=rngAfterCell).Column
On Error GoTo 0
End Select
Else
Select Case rcColRow
Case 1
On Error Resume Next
FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=xlWhole).Row
On Error GoTo 0
Case 2
On Error Resume Next
FindRowCol = rngToSearch.Find(What:=strSearchVal, LookIn:=xlValues, LookAt:=xlWhole).Column
On Error GoTo 0
End Select
End If
End Function
Sub ShowAllSheets()
Dim sht As Worksheet
For Each sht In ThisWorkbook.Sheets
sht.Visible = xlSheetVisible
Next sht
End Sub
Sub AddNamedRange(strName As String, rngRange As Range)
ThisWorkbook.Names.Add Name:=strName, RefersTo:=rngRange
End Sub
以上是关于vbscript 其他VBA - 来自：<script src =“https://gist.github.com/pudelosha/c997c6091fbb4103e5fe1dc21692的主要内容，如果未能解决你的问题，请参考以下文章
将 Staad 与 VBS 一起使用（将 VBA 文档转换为 VBscript）