'Place the code below into the standard module Sub ArrayTest() Dim arrValue(1 To 100, 1 To 2) As Integer Dim varTest As Variant Dim intCounter As Integer, intTest As Integer intTest = CInt(InputBox("Controldigit enter:", , 5)) For intCounter = 1 To 100 arrValue(intCounter, 1) = intCounter arrValue(intCounter, 2) = intCounter * 10 Next intCounter varTest = Application.VLookup(intTest, arrValue, 2, 0) If IsError(varTest) Then Beep MsgBox "Value Not Found!" Else MsgBox "Value: " & varTest End If End Sub
'Place the following user defined function in a standard VBA module
Function SplitHype(rng As Range, iInfo As Integer) Select Case iInfo Case 0: SplitHype = rng.Value Case 1: SplitHype = rng.Hyperlinks(1).Address Case 2: SplitHype = rng.Hyperlinks(1).SubAddress End Select End Function
'Place the below UDF(user defined function)in a standard VBA module.
Function CountColor(rng As Range, iColor As Integer) Dim rngAct As Range Dim iCount As Integer For Each rngAct In rng.Cells If rngAct.Interior.ColorIndex = iColor And _ Not IsEmpty(rngAct) Then iCount = iCount + 1 End If Next rngAct CountColor = iCount End Function
Formula is =countcolor(A1:C6,6)
'Place the code below into the standard module Sub File_exists() Dim dName$ dName = "c:exceltest.xls" If Dir(dName) <> "" Then MsgBox dName & " exists!" Else MsgBox dName & " does not exist!" End If End Sub
'Place the code below into the standard module
Range("A2").Formula = _
'Place the code below into the standard module
Dim z%, i%
z = ActiveCell.Row
For i = 1 To 7
Cells(z - 1 + i, 6).FormulaArray = _
"=SUM((r2c1:r23c2=1)*(r2c3:r23c3=" & i & ")*(r2c[-2]:r23c[-2]))"
Private Sub Worksheet_Change(ByVal Target As Range)If Not Intersect(Target, Range("A1:A5")) Is Nothing Then Range("A1:A5").Sort Range("A1"), xlAscending, Header:=xlYesEnd IfEnd Sub
Microsoft added this long anticipated function to Excel early part of the 2020. XLOOKUP replaces the old VLOOKUP and offers a whole lot more power and flexibility. I added to Sample Excel Macros section a file to illustrate various different ways of utilizing this valuable function.
On my Projects > Sample Excel Files section I added a file RangeComparison1.xlsx. If curious you may want to open this file and check it for yourself. Change a cell value anywhere in either of the ranges on Sheet1 or Sheet2 then click on the button located on Sheet1. If there is a change i.e. ranges are not identical then VBA will generate another Excel file indicating where the difference is and will highlight in red color, if data is exactly the same then VBA will tell you that as well. There were times that I had to deal with comparing two data sets and tried to use many convoluted and cumbersome formula based methods after I got sick and tired of that process and I have started using this method where applicable.
Put the below code in a standard module then assign it to a button. Sub Link2Value() Dim rng As Range For Each rng In ActiveSheet.UsedRange.Cells If rng.HasFormula Then If InStr(rng.Formula, "[") Then rng.Value = rng.Value End If End If Next rngEnd Sub
Extracting a year from text is possible using string functions if the location of the year is fixed in the text within each cell. But in a free form sentence where the year is used anywhere according to the context there is no way of knowing where in the cell the year is located. In this case UDF (user defined function) created in VBA solves the issue and it is stored like another Excel built-in function so typing the name of this function is sufficient in the fomula line. Refer to the file on macro samples for this example called ExtractYerFromText.xls. Below is the code used to create the said UDF.Function GetYear(txt As String) As Integer Dim intCounter As Integer txt = txt & " " For intCounter = 1 To Len(txt) - 4 If Mid(txt, intCounter, 5) Like "*#### *" Then GetYear = Mid(txt, intCounter, 4) Exit Function End If Next intCounterEnd Function
Note - - UDF as entered would be =GetYear(A2)
Assigned to a forms button:
Sub YearCaller() Dim x As Integer x = GetYear(Range("A2").Value) MsgBox xEnd Sub
Use this code block in the standard module to print the range without blank rows in it. Sub PrintRows() Dim TB As Worksheet Dim i%, lRow% Application.ScreenUpdating = False Set TB = Worksheets("Sheet1") lRow = TB.[a16384].End(xlUp).Row For i = 1 To lRow If IsEmpty(TB.Cells(i, 1)) Then TB.Rows(i).EntireRow.Hidden = True Next i TB.PrintPreview TB.Range(TB.Cells(1, 1), TB.Cells(lRow, 1)).EntireRow.Hidden = FalseApplication.ScreenUpdating = TrueEnd Sub
Please refer to the file named CreateAccessTable.xls on Projects > Sample Macros section. After downloading this file click on the button and you will see that a new Access file is created and the data on the tab gets appended to the table on that Access file.
You can put the below code in the standard module and assign a button to it on the worksheet. This code sorts the values in a range per the frequency of the values. Regular sort function can't do that so VBA comes handy for this goal. Sub Sort() Dim intRow As Integer, intCounter As Integer, intArr As Integer Range("A1").Sort key1:=Range("A1"), order1:=xlAscending, header:=xlNo Range("B1").Formula = "=countif(A:A,A1)" Range("B1:B" & Range("A1").CurrentRegion.Rows.Count).FillDown Range("A1").Sort key1:=Range("B1"), order1:=xlDescending, header:=xlNo Columns("B").ClearContentsEnd Sub
Copy below code in a statndard module of the VB editor. It colors the maximum value in the range in violet. Sub ConditionalFormat() With Selection .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:= _ "=" & Range("Field").Cells(1).Address(False, False) & _ "=MAX(" & Selection.Address & ")" .FormatConditions(1).Interior.ColorIndex = 39 End WithEnd Sub
Place the code below into the standard module of the VB Editor. This is an example of a user defined function. The function name "FieldComparing" can be typed into the formula line for two ranges to be compared. This acts similar to any other Excel built-in formula on the worksheet. Function FieldComparing(mgOne, rngTwo) As Boolean Dim rngCell As Range Dim intCount% Dim Switch As Boolean For Each rngCell In mgOne intCount = intCount + 1 If rngCell <> rngTwo.Cells(intCount) Then Switch = True Exit For End If Next rngCell If Switch = False Then FieldComparing = TrueEnd Function
Assign this code to a forms button:
Sub DatesAndWeeks() Dim iCount As Integer, iCounter As Integer If Month(DateSerial(Year(Date), 2, 29)) = 2 Then iCount = 366 Else iCount = 365 End If For iCounter = 1 To iCount Cells(iCounter, 1) = DateSerial(Year(Date), 1, iCounter) Cells(iCounter, 2) = WeekNumberID(Cells(iCounter, 1)) Next iCounterEnd Sub
Enter in a module as support for the above macro:
Private Function WeekNumberID(dat As Date) As Integer Dim dbl As Double dbl = DateSerial(Year(dat + (8 - Weekday(dat)) Mod 7 - 3), 1, 1) WeekNumberID = (dat - dbl - 3 + (Weekday(dbl) + 1) Mod 7) 7 + 1End Function
'Place the code below into the standard moduleSub ToMark()Dim gCell As RangeDim StartDim EndDate On Error GoTo ErrorHandler Start = CDate(InputBox("Start:")) Set gCell = Columns(1).Find(DateValue(Start), LookIn:=xlFormulas) If gCell Is Nothing Then GoTo ErrorHandler gCell.Interior.ColorIndex = 3 EndDate = CDate(InputBox("End:")) Set gCell = Columns(1).Find(DateValue(EndDate), LookIn:=xlFormulas) If gCell Is Nothing Then GoTo ErrorHandler gCell.Interior.ColorIndex = 3 EndErrorHandler: Beep MsgBox "Not Valid Date!"End Sub
See the sample file posted on Various Macro Samples section under Projects menu as of 12/14/2017. This file does not have any VBA code or a macro but shows the array function example in the worksheet formula box. Note the explanation box on the worksheet.
For this example please refer to the file named as as INDEX_MATCH SAMPLE.xlsm on the Excel Samples part of the Projects section of this site. On this file tab named Match has INDEX_MATCH function along with the INDIRECT function. The yellow cell uses the data validation list seeing the range E10:E14 as a reference. Notice that the formulas in the column F use the INDIRECT function along with the INDEX_MATCH to show the matching values per the selection in the yellow cell in the G column. Formula reads as=INDEX(INDIRECT($E$2),MATCH(R3,IF($P$2:$P$250=Q3,$K$2:$K$250),0))
INDEX and MATCH function offers a power where VLOOKUP fails. For example you can use VLOOKUP to get the corresponding value for a lookup value in a different range on a different tab even on a different file. Yet the same lookup value might have different values associated with it, say it is a category per criteria and several values roll into it on the next column. In this case VLOOKUP will sta on the first occurance of that lookup value and if you copy this down you will get the valuw for that occurance only. But using INDEX-MATCH function resolves this issue. below is provided a sample function that can be used on the Excel's formula line. You can tweak it for your data and give it a try. On my Excel macro samples you can actually find a working copy of this code. =IF(ISERROR(INDEX($A$1:$B$22,SMALL(IF($A$1:$A$22=$O$1,ROW($A$1:$A$22)),ROW(6:6)),2)),"",INDEX($A$1:$B$22,SMALL(IF($A$1:$A$22=$O$1,ROW($A$1:$A$22)),ROW(6:6)),2))
Analysis Office (AO) for Excel looks like running into some issues with the 64-bit Office installation. This is more appearent with the AO ver. 2.4 but ver. 2.5 might have a better performance. This issue might be resolved by installing some additional patches for the AO. Below link offers some good insight on this issue. https://wiki.scn.sap.com/wiki/display/BI/Analysis+Office+Installation+and+Update
Below VBA code refreshes dynamically changing range for multiple pivot tables. If let's say there are several pivot tables on the file and after each update their range is subject to change. In this case one has to manually readjust the range for each pivot table and imagine if there are 20 or more of them and this needs to be done weekly or monthly, so it takes a painful amount of time. By incorporating the code displayed below one can update all the pivots on the file with a single click of a button. Just change the worksheet names of your file and pivot table names displayed on the top left corner of the pivot page when you are on the pivot area accordingly after palcing the code in a VBA module. Sub UpdatePivotTableRange()Dim Data_Sheet As WorksheetDim Pivot_Sheet As WorksheetDim StartPoint As RangeDim DataRange As RangeDim PivotName As StringDim NewRange As StringDim LastCol As LongDim lastRow As Long'Set Pivot Table & Source WorksheetSet Data_Sheet = ThisWorkbook.Worksheets("Data")Set Pivot_Sheet = ThisWorkbook.Worksheets("Pivot")'Enter in Pivot Table NamePivotName = "PivotTable1"'Defining Staring Point & Dynamic RangeData_Sheet.ActivateSet StartPoint = Data_Sheet.Range("A1")LastCol = StartPoint.End(xlToRight).ColumnDownCell = StartPoint.End(xlDown).RowSet DataRange = Data_Sheet.Range(StartPoint, Cells(DownCell, LastCol))NewRange = Data_Sheet.Name & "!" & DataRange.Address(ReferenceStyle:=xlR1C1)'Change Pivot Table Data Source Range AddressPivot_Sheet.PivotTables(PivotName). _ChangePivotCache ActiveWorkbook. _PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange) 'Ensure Pivot Table is RefreshedPivot_Sheet.PivotTables(PivotName).RefreshTable'Complete MessagePivot_Sheet.ActivateMsgBox "Your Pivot Table is now updated."End Sub