Would anyone be kind enough to highlight the flaw in the logic of my code. No errors are thrown but I am not getting the desired result.
Logic: The macro will get all properties of all legends of master chart, store it in an array and then apply the same formatting for other charts in the whole ppt from the array.
Code:
Sub FormatLegendsOfCharts(
Dim NewSel As Selection
Set NewSel = ActiveWindow.Selection
On Error Resume Next
Dim ThisShape As Shape
Set ThisShape = ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
If ThisShape Is Nothing Then GoTo 100:
If ThisShape.HasChart = True Then
Dim ThisChart As Chart
Set ThisChart = ThisShape.Chart
If ThisChart.ChartType = xlLineMarkers Or ThisChart.ChartType = xlLine Then
Dim GetSourceFormatting() As Variant
ReDim GetSourceFormatting(ThisChart.SeriesCollection.Count, 8)
Dim i As Long
For i = 1 To ThisChart.SeriesCollection.Count
Dim EachSeries As Series
Set EachSeries = ThisChart.SeriesCollection(i)
GetSourceFormatting((i - 1), 0) = EachSeries.Border.Color
GetSourceFormatting((i - 1), 1) = EachSeries.Border.Weight
GetSourceFormatting((i - 1), 2) = EachSeries.Format.Line.ForeColor.RGB
GetSourceFormatting((i - 1), 3) = EachSeries.Format.Line.Weight
GetSourceFormatting((i - 1), 4) = EachSeries.MarkerStyle
GetSourceFormatting((i - 1), 5) = EachSeries.MarkerSize
GetSourceFormatting((i - 1), 6) = EachSeries.MarkerBackgroundColor
GetSourceFormatting((i - 1), 7) = EachSeries.MarkerForegroundColor
GetSourceFormatting((i - 1), 8) = EachSeries.Name
Next
Call FormatLegendsInOtherCharts(GetSourceFormatting())
Else
MsgBox "Macro only works on line chart."
End If
Else
MsgBox "Please select master chart"
End If
MsgBox "Done"
Exit Sub
100:
MsgBox "Please select master chart"
End Sub
'-----------------------------------------------------------------
Private Sub FormatLegendsInOtherCharts(Database() As Variant)
Dim j As Long
Dim k As Long
For j = 1 To ActivePresentation.Slides.Count
Dim ThisSlide As Slide
Set ThisSlide = ActivePresentation.Slides(j)
For k = 1 To ThisSlide.Shapes.Count
Dim ThisOtherShape As Shape
Set ThisOtherShape = ThisSlide.Shapes(k)
If ThisOtherShape.HasChart = True Then
Dim ThisOtherChart As Chart
Set ThisOtherChart = ThisOtherShape.Chart
If ThisOtherChart.ChartType = xlLineMarkers Then
Call FormattingHappensHere(ThisOtherChart, Database())
End If
End If
Next
Next
End Sub
'--------------------------------------------------------------------
Private Sub FormattingHappensHere(OurChart As Chart, Databasee() As Variant)
Dim i As Long
Dim k As Long
For i = 1 To OurChart.SeriesCollection.Count
Dim EachOtherSeries As Series
Set EachOtherSeries = OurChart.SeriesCollection(i)
For k = 1 To UBound(Databasee())
If EachOtherSeries.Name = Databasee((k - 1), 8) Then
EachOtherSeries.Border.Color = Databasee((k - 1), 0)
EachOtherSeries.Border.Weight = Databasee((k - 1), 1)
EachOtherSeries.Format.Line.ForeColor.RGB = Databasee((k - 1), 2)
EachOtherSeries.Format.Line.Weight = Databasee((k - 1), 3)
EachOtherSeries.MarkerStyle = Databasee((k - 1), 4)
EachOtherSeries.MarkerSize = Databasee((k - 1), 5)
EachOtherSeries.MarkerBackgroundColor = Databasee((k - 1), 6)
EachOtherSeries.MarkerForegroundColor = Databasee((k - 1), 7)
End If
Next
Set EachOtherSeries = Nothing
Next
End Sub
You have:
If ThisOtherChart.ChartType = xlLineMarkers Then
Call FormattingHappensHere(ThisOtherChart, Database())
End If
but you probably meant:
If ThisOtherChart.ChartType = xlLine Or ThisOtherChart.ChartType = xlLineMarkers Then
EDIT: this worked for me (some refactoring for clarity)
Option Explicit
Sub FormatLegendsOfCharts()
Dim MasterChart As Chart, pres As Presentation
Dim GetSourceFormatting() As Variant, i As Long
Set pres = ActivePresentation
Set MasterChart = SelectedChart()
If MasterChart Is Nothing Then Exit Sub
ReDim GetSourceFormatting(MasterChart.SeriesCollection.Count, 8)
For i = 1 To MasterChart.SeriesCollection.Count
With MasterChart.SeriesCollection(i)
GetSourceFormatting((i - 1), 0) = .Border.Color
GetSourceFormatting((i - 1), 1) = .Border.Weight
GetSourceFormatting((i - 1), 2) = .Format.Line.ForeColor.RGB
GetSourceFormatting((i - 1), 3) = .Format.Line.Weight
GetSourceFormatting((i - 1), 4) = .MarkerStyle
GetSourceFormatting((i - 1), 5) = .MarkerSize
GetSourceFormatting((i - 1), 6) = .MarkerBackgroundColor
GetSourceFormatting((i - 1), 7) = .MarkerForegroundColor
GetSourceFormatting((i - 1), 8) = .Name
End With
Next
FormatLegendsInOtherCharts pres, GetSourceFormatting
MsgBox "Done"
End Sub
'get the user-selected chart (or Nothing if no valid selection)
Private Function SelectedChart() As Chart
Dim ThisShape As Shape
Dim ThisChart As Chart
On Error Resume Next
Set ThisShape = ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
If ThisShape Is Nothing Then
MsgBox "Please select a Line chart"
Exit Function
Else
If Not ThisShape.HasChart Then
MsgBox "Please select a Line chart"
Exit Function
Else
Set ThisChart = ThisShape.Chart
If Not OKChart(ThisChart) Then
MsgBox "Macro only works on line chart."
Exit Function
End If
End If
End If
Set SelectedChart = ThisChart
End Function
'check chart type
Private Function OKChart(cht As Chart)
OKChart = cht.ChartType = xlLine Or cht.ChartType = xlLineMarkers
End Function
Private Sub FormatLegendsInOtherCharts(pres As Presentation, Database() As Variant)
Dim j As Long, k As Long, ThisOtherChart As Chart
Dim ThisSlide As Slide, ThisOtherShape As Shape
For j = 1 To pres.Slides.Count
Set ThisSlide = pres.Slides(j)
For k = 1 To ThisSlide.Shapes.Count
Set ThisOtherShape = ThisSlide.Shapes(k)
If ThisOtherShape.HasChart = True Then
Set ThisOtherChart = ThisOtherShape.Chart
If OKChart(ThisOtherChart) Then
FormattingHappensHere ThisOtherChart, Database()
End If
End If
Next
Next
End Sub
Private Sub FormattingHappensHere(OurChart As Chart, Databasee() As Variant)
Dim i As Long, k As Long
For i = 1 To OurChart.SeriesCollection.Count
With OurChart.SeriesCollection(i)
For k = 1 To UBound(Databasee())
If .Name = Databasee((k - 1), 8) Then
.Border.Color = Databasee((k - 1), 0)
.Border.Weight = Databasee((k - 1), 1)
.Format.Line.ForeColor.RGB = Databasee((k - 1), 2)
.Format.Line.Weight = Databasee((k - 1), 3)
.MarkerStyle = Databasee((k - 1), 4)
.MarkerSize = Databasee((k - 1), 5)
.MarkerBackgroundColor = Databasee((k - 1), 6)
.MarkerForegroundColor = Databasee((k - 1), 7)
End If
Next
End With
Next
End Sub
Related
I am new to VBA and do not know whether my function is being correctly utilized or whether the function itself is flawed.
My subprocedure is as follows:
Sub InsertEquitiesBonds()
Dim ws As Worksheet, i As Integer
Set ws = Worksheets("PnL")
ws.Range("B3").Value = "Equities"
Worksheets("SummaryEquities").Range("MarketsEquities").Copy ws.Range("C4")
Dim LastUsedCell As Range
Set LastUsedCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
LastUsedCell.Offset(1, -1).Value = "Bonds"
Worksheets("SummaryBonds").Range("MarketsBonds").Copy LastUsedCell.Offset(2, 0)
For i = 4 To ws.Range("C" & Rows.Count).End(xlUp).Row
ws.Cells(i, 4).Value = OurFees(Range("C" & i))
Next i
Range("A1").Select
End Sub
As described in the InsertEquitiesBonds() the code works until I have to use the function OurFees that it actually just ignores. This leads me to the question am I not referring to my function correctly or if I am, is the function inevitably flawed?
OurFees() function is described as the following:
Function OurFees(rng As Range)
If rng.Value.IsEmpty = True Then
OurFees = ""
Else
Dim BasisPoint, VolMin, VolDistr As Range
If Columns("B").Find("Bonds").Row < rng.Row Then
With Worksheets("CheatSheet_Bonds")
BasisPoint = Application.WorksheetFunction.Index(Range("A5:E6"), Application.WorksheetFunction.Match(rng, Range("C5:C6"), 0), 3)
VolMin = Application.WorksheetFunction.Index(Range("A5:E6"), Application.WorksheetFunction.Match(rng, Range("D5:D6"), 0), 4)
End With
With Worksheets("SummaryBonds")
VolDistr = Application.WorksheetFunction.Index(Range("B12:C50"), Application.WorksheetFunction.Match(rng, Range("B12:B50"), 0), 2)
OurFees = Application.WorksheetFunction.Max(Range("D9") * BasisPoint, VolMin) * Range("D8") * VolDistr
End With
Else
With Worksheets("CheatSheet_Equities")
BasisPoint = Application.WorksheetFunction.Index(Range("A4:D21"), Application.WorksheetFunction.Match(rng, Range("B4:B21"), 0), 3)
VolMin = Application.WorksheetFunction.Index(Range("A4:D21"), Application.WorksheetFunction.Match(rng, Range("B4:B21"), 0), 4)
End With
With Worksheets("SummaryEquities")
VolDistr = Application.WorksheetFunction.Index(Range("B12:C40"), Application.WorksheetFunction.Match(rng, Range("B12:B40"), 0), 2)
OurFees = Application.WorksheetFunction.Max(Range("D9") * BasisPoint, VolMin) * Range("D8") * VolDistr
End With
End If
End If
End Function
try with below
For i = 4 To ws.Range("C" & Rows.Count).End(xlUp).Row
ws.Cells(i, 4).Value = OurFees(Range("C" & i))
Next i
I'm currently on a project that search in a product database all non-referenced product (blank fields). When I click on the button that opens a userform, error 13 is displayed, here is the code:
Dim i As Integer
Dim j As Integer
Dim t As Integer
Dim r As Integer
t = 1
While Feuil3.Cells(t, 1) <> ""
t = t + 1
Wend
t = t - 1
For r = 2 To t
If Feuil3.Cells(r, 3) = "" Then
i = 1
While Feuil2.Cells(i, 1) <> ""
i = i + 1
Wend
Feuil2.Cells(i, 1) = Feuil3.Cells(r, 2)
End If
Next
i = 1
While Feuil2.Cells(i, 1) <> ""
i = i + 1
Wend
For j = 2 To i
If Feuil2.Cells(j, 2) = "" Then
list51.AddItem Feuil2.Cells(j, 1)
End If
Next
End Sub
It appears that the error comes from this line:If Feuil3.Cells(r, 3) = "" Then
My skills in VBA are limited, do you have any idea on how to fix this problem?
Thanks,
Have a look at this. Should do the same just a lot less iteratively
Dim Feuil2Rng As Range, Feuil3Rng As Range
Dim c
With Feuil3
Set Feuil3Rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
For Each c In Feuil3Rng
If c.Offset(0, 2) = vbNullString Then
With Feuil2
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = c.Offset(0,1)
End With
End If
Next
With Feuil2
Set Feuil2Rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
For Each c In Feuil2Rng
If c.Offset(0, 1) = vbNullString Then
list51.AddItem c.Value2
End If
Next
I have made a userform that allows the user to select a table and add rows to it and fill those rows with various information, all from the userform. I have run into a few problems with this.
First after adding or during adding the items (after hitting submit) excel would crash. It occurs randomly and is hard to reproduce.
Second after running the macro there is a good chance that all the cells in the workbook and every other object except the userform button will stop working, meaning you can't edit interact or even select anything. Then when I close the workbook excel crashes after saving. This is my major offender and I think causes the other problem.
What causes this freezing and why does it occur? How do I fix it? I have looked around and haven't found anything circumstantial. One post said that I should try editing the table with no formatting on it and I did that and it didn't work.
I can provide the excel workbook at a request basis via pm.
The code:
On Activate -
Public Sub UserForm_Activate()
Set cBook = ThisWorkbook
Set dsheet = cBook.Sheets("DATA")
End Sub
Help Checkbox -
Private Sub cbHelp_Click()
If Me.cbHelp.Value = True Then
Me.lbHelp.Visible = True
Else
Me.lbHelp.Visible = False
End If
End Sub
Brand combobox -
Public Sub cmbBrand_Change()
brandTableName = cmbBrand.Value
brandTableName = CleanBrandTableName(brandTableName)
'if brand_edit is not = to a table name then error is thrown
On Error Resume Next
If Err = 380 Then
Exit Sub
Else
cmbItemID.RowSource = brandTableName
End If
On Error GoTo 0
'Set cmbItemID's text to nothing after changing to a new brand
cmbItemID.Text = ""
End Sub
CleanBrandTableName(brandTableName) function -
Option Explicit
Public Function CleanBrandTableName(ByVal brandTableName As String) As String
Dim s As Integer
Dim cleanResult As String
For s = 1 To Len(brandTableName)
Select Case Asc(Mid(brandTableName, s, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122:
cleanResult = cleanResult & Mid(brandTableName, s, 1)
Case 95
cleanResult = cleanResult & " "
Case 38
cleanResult = cleanResult & "and"
End Select
Next s
CleanBrandTableName = Replace(WorksheetFunction.Trim(cleanResult), " ", "_")
End Function
Public Function CleanSpecHyperlink(ByVal specLink As String) As String
Dim cleanLink As Variant
cleanLink = specLink
cleanLink = Replace(cleanLink, "=HYPERLINK(", "")
cleanLink = Replace(cleanLink, ")", "")
cleanLink = Replace(cleanLink, ",", "")
cleanLink = Replace(cleanLink, """", "")
cleanLink = Replace(cleanLink, "Specs", "")
CleanSpecHyperlink = cleanLink
End Function
Browse button -
Public Sub cbBrowse_Click()
Dim rPos As Long
Dim lPos As Long
Dim dPos As Long
specLinkFileName = bFile
rPos = InStrRev(specLinkFileName, "\PDFS\")
lPos = Len(specLinkFileName)
dPos = lPos - rPos
specLinkFileName = Right(specLinkFileName, dPos)
Me.tbSpecLink.Text = specLinkFileName
End Sub
bFile function -
Option Explicit
Public Function bFile() As String
bFile = Application.GetOpenFilename(Title:="Please choose a file to open")
If bFile = "" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Function
End If
End Function
Preview button -
Private Sub cbSpecs_Click()
If specLinkFileName = "" Then Exit Sub
cBook.FollowHyperlink (specLinkFileName)
End Sub
Add Item button -
Private Sub cbAddItem_Click()
Dim brand As String
Dim description As String
Dim listPrice As Currency
Dim cost As Currency
Dim Notes As String
Dim other As Variant
itemID = Me.tbNewItem.Text
brand = Me.tbBrandName.Text
description = Me.tbDescription.Text
specLink = Replace(specLinkFileName, specLinkFileName, "=HYPERLINK(""" & specLinkFileName & """,""Specs"")")
If Me.tbListPrice.Text = "" Then
listPrice = 0
Else
listPrice = Me.tbListPrice.Text
End If
If Me.tbCost.Text = "" Then
cost = 0
Else
cost = Me.tbCost.Text
End If
Notes = Me.tbNotes.Text
other = Me.tbOther.Text
If Me.lbItemList.listCount = 0 Then
x = 0
End If
With Me.lbItemList
Me.lbItemList.ColumnCount = 8
.AddItem
.List(x, 0) = itemID
.List(x, 1) = brand
.List(x, 2) = description
.List(x, 3) = specLink
.List(x, 4) = listPrice
.List(x, 5) = cost
.List(x, 6) = Notes
.List(x, 7) = other
x = x + 1
End With
End Sub
Submit button -
Private Sub cbSubmit_Click()
Dim n As Long
Dim v As Long
Dim vTable() As Variant
Dim r As Long
Dim o As Long
Dim c As Long
Dim w As Variant
Set brandTable = dsheet.ListObjects(brandTableName)
o = 1
listAmount = lbItemList.listCount
v = brandTable.ListRows.Count
w = 0
For c = 1 To listAmount
If brandTable.ListRows(v).Range(, 1).Value <> "" Then
brandTable.ListRows.Add alwaysinsert:=True
brandTable.ListRows.Add alwaysinsert:=True
Else
brandTable.ListRows.Add alwaysinsert:=True
End If
Next
ReDim vTable(1000, 1 To 10)
For n = 0 To listAmount - 1
vTable(n + 1, 1) = lbItemList.List(n, 0)
vTable(n + 1, 2) = lbItemList.List(n, 1)
vTable(n + 1, 3) = lbItemList.List(n, 2)
vTable(n + 1, 5) = lbItemList.List(n, 4)
vTable(n + 1, 6) = lbItemList.List(n, 5)
vTable(n + 1, 7) = lbItemList.List(n, 6)
vTable(n + 1, 8) = lbItemList.List(n, 7)
If lbItemList.List(n, 3) = "" Then
ElseIf lbItemList.List(n, 3) <> "" Then
vTable(n + 1, 4) = lbItemList.List(n, 3)
End If
If n = 0 And brandTable.DataBodyRange(1, 1) <> "" Then
For r = 1 To brandTable.ListRows.Count
If brandTable.DataBodyRange(r, 1) <> "" Then
o = r + 1
' brandTable.ListRows.Add alwaysinsert:=True
End If
Next
End If
brandTable.ListColumns(1).DataBodyRange(n + o).Value = vTable(n + 1, 1)
brandTable.ListColumns(2).DataBodyRange(n + o).Value = vTable(n + 1, 2)
brandTable.ListColumns(3).DataBodyRange(n + o).Value = vTable(n + 1, 3)
brandTable.ListColumns(4).DataBodyRange(n + o).Value = vTable(n + 1, 4)
brandTable.ListColumns(5).DataBodyRange(n + o).Value = vTable(n + 1, 5)
brandTable.ListColumns(6).DataBodyRange(n + o).Value = vTable(n + 1, 6)
brandTable.ListColumns(7).DataBodyRange(n + o).Value = vTable(n + 1, 7)
brandTable.ListColumns(8).DataBodyRange(n + o).Value = vTable(n + 1, 8)
Next
brandTable.DataBodyRange.Select
Selection.Font.Bold = True
Selection.WrapText = True
brandTable.ListColumns(5).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
brandTable.ListColumns(6).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
Unload Me
End Sub
Remove Items button -
Private Sub cbRemoveItems_Click()
Dim intCount As Long
For intCount = lbItemList.listCount - 1 To 0 Step -1
If lbItemList.Selected(intCount) Then
lbItemList.RemoveItem (intCount)
x = x - 1
End If
Next intCount
End Sub
There is other code that does things for the other tabs but they don't interact with this tabs code.
I trying to get a third order LinEst function in VBA. However, the error always come out as Expected array when it reaches Ubound(xl).
Option Explicit
Sub RB()
Dim xl As Range, e As Double
Dim yl As Range, s As Variant
Dim X
With ThisWorkbook.Worksheets("Sheet1")
Set yl = .Range(.Cells(17, 7), .Cells(93, 7))
Set xl = .Range(.Cells(17, 1), .Cells(93, 1))
ReDim arrX3(1 To UBound(xl), 1 To 3) As Double
For i = LBound(xl) To UBound(xl)
arrX2(i, 1) = xl(i, 1)
arrX2(i, 2) = xl(i, 1) * xl(i, 1)
arrX2(i, 3) = xl(i, 1) * xl(i, 1) * xl(i, 1)
Next
X = Application.LinEst(yl, arrX3)
.Range(.Cells(12, 12), .Cells(15, 14)).Value = Application.Transpose(X)
End With
End Sub
xl is a Range and not an array. So, Ubound(xl) won't work. While I do not understand what you're code is trying to achieve, I believe that you are looking for something along the line like this:
Option Base 1
Option Explicit
Sub RB()
Dim xl As Range, e As Double
Dim yl As Range, s As Variant
Dim X As Variant, i As Long
e = 76
With ThisWorkbook.Worksheets("Sheet1")
Set yl = .Range(.Cells(17, 7), .Cells(e - 1, 7))
Set xl = .Range(.Cells(17, 1), .Cells(e - 1, 1))
Debug.Print "First row in xl is " & xl.Row
Debug.Print "Range xl has " & xl.Rows.Count & " rows"
Debug.Print "Last row in xl is " & xl.Rows.Count + xl.Row - 1
ReDim arrX3(1 To xl.Rows.Count, 1 To 3) As Double
For i = 1 To xl.Rows.Count
arrX3(i, 1) = xl.Cells(i, 1)
arrX3(i, 2) = xl.Cells(i, 1) * xl.Cells(i, 1)
arrX3(i, 3) = xl.Cells(i, 1) * xl.Cells(i, 1) * xl.Cells(i, 1)
Next i
X = Application.LinEst(yl, arrX3)
.Range(.Cells(12, 12), .Cells(15, 14)).Value = Application.Transpose(X)
End With
End Sub
Note, that I added a few Debug.Print which you might want to have a look at.
xl is declared to be a range and ranges don't have a Ubound.
Change the declaration of xl from Range to Variant and replace the line
Set xl = .Range(.Cells(17, 1), .Cells(93, 1))
by
xl = .Range(.Cells(17, 1), .Cells(93, 1)).Value
I'm not sure if this will be enough to make your code run as expected, but it will at least get rid of the error that you describe.
I get run time error 13 when executing following code
Dim sh, shmem As Worksheet
Dim rw As Range
Set shmem = Sheets("SHEET1")
Set sh = Sheets("SHEET2")
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "" And sh.Cells(rw.Row, 2).Value = "" Then
Exit For
End If
With Application.WorksheetFunction
Dim bdaytest As Variant
Dim match1 As Double
bdaytest = .Index((shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)) * (shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)), 0)
'match1 = .Match(1, .Index((shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)) * (shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)), 0), 0)
bdaytest = .Index(1, shmem.Range("D2:D121"), match1)
End With
Next rw
The Error Happens in following line which I extracted from the 2 line (commented out now)
bdaytest = .Index((shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)) * (shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)), 0)
'match1 = .Match(1, .Index((shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)) * (shmem.Range("A2:A121") = sh.Cells(rw.Row, 1)), 0), 0)
I understand that the error must happen because bdaytest is the wrong data type but I'm not sure and up to now I couldn't find any solution. Thanks in advance for any suggestions.
Edit: I want to find out the Row Number of the Line where 2 Columns (A & B) have a requested Value. The requested Value is found in sh.Cells(rw.Row, 1) and sh.Cells(rw.Row, 2)
You can't create arrays using = and * like that in VBA, unlike in a formula. What you can do is use Application.Countifs like this:
Dim sh As Worksheet
Dim shmem As Worksheet
Dim rw As Range
Set shmem = Sheets("SHEET1")
Set sh = Sheets("SHEET2")
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "" And sh.Cells(rw.Row, 2).Value = "" Then
Exit For
End If
With Application
Dim bdaytest As Variant
Dim match1 As Double
bdaytest = .Match(1, .CountIfs(sh.Cells(rw.Row, 1), shmem.Range("A2:A121"), _
sh.Cells(rw.Row, 2), shmem.Range("B2:B121")), 0)
If Not IsError(bdaytest) Then bdaytest = shmem.Range("D2:D121").Cells(bdaytest)
End With
Next rw
Note: WorksheetFunction.Countifs will not work.