Make Your Microsoft Dynamics Investment Count & Drastically Decrease Training Time by Providing Intuitive Step-By-Step WalkThru Tutorials.
Become a Premium Member and unlock a new, free course in leading technologies each month.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
=IF(SUMPRODUCT((H1:K1=$A$1:$D$1)*(H2:K2=$A$2:$D$2)*(H3:K3=$A$3:$D$3)*(H4:K4=$A$4:$D$4)),"Match","x")
=IF(SUMPRODUCT((H1=$A$1)*(I1=$B$1)*(J1=$C$1)*(K1=$D$1)*(H2=$A$2)*(I2=$B$2)*(J2=$C$2)*(K2=$D$2)*(H3=$A$3)*(I3=$B$3)*(J3=$C$3)*(K3=$D$3)*(H4=$A$4)*(I4=$B$4)*(J4=$C$4)*(K4=$D$4)),"Match " &G1&", "&G2&", "&G3&", "&G4,"No Match")
=IF(SUMPRODUCT((H1:K1=$A$1:$D$1)*(H2:K2=$A$2:$D$2)*(H3:K3=$A$3:$D$3)*(H4:K4=$A$4:$D$4))=4,"Match","x")
=IF(AND(H1:K1=$A$1:$D$1,H2:K2=$A$2:$D$2,H3:K3=$A$3:$D$3,H4:K4=$A$4:$D$4),"Match","x")
Sub Macro1()
'
' Macro1 Macro
'
'
Range("L1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Goto Reference:="Macro1"
Range("G1:L22").Select
Selection.Copy
Sheets("Sheet2").Select
Range("G1").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-4
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$G$1:$L$22").AutoFilter Field:=6, Criteria1:="Followup"
Selection.Copy
Range("J33").Select
Sheets("Sheet3").Select
Range("G1").Select
ActiveSheet.Paste
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("L2").Select
End Sub
Sub Test()
Dim cel As Range, rgPattern As Range, rgTest As Range
Dim v As Variant
With Worksheets("Sheet1")
Set rgPattern = .Range("A1:D4")
Set rgTest = .Range("H1:K22")
End With
v = MatchPattern(rgPattern.Value, rgTest.Value)
If IsArray(v) Then
Set cel = rgTest.Cells(v(0), v(1))
Application.Goto cel
cel.Resize(rgPattern.Rows.Count, rgPattern.Columns.Count).Select
MsgBox "Top left cell of matching range is: " & cel.Address(False, False)
Else
MsgBox "Pattern not found in test range"
End If
End Sub
Function MatchPattern(PatternArray As Variant, TestArray As Variant) As Variant
Dim i As Long, ii As Long, j As Long, jj As Long, pBase As Long, pRows As Long, pCols As Long, _
tBase As Long, tRows As Long, tCols As Long
Dim vResults As Variant
Dim bMatched As Boolean
MatchPattern = "Not found"
pBase = LBound(PatternArray)
pRows = UBound(PatternArray)
pCols = UBound(PatternArray, 2)
tBase = LBound(TestArray)
tRows = UBound(TestArray)
tCols = UBound(TestArray, 2)
ReDim vResults(tBase To tRows - (pRows - pBase), tBase To tCols - (pCols - pBase))
For i = tBase To tRows - (pRows - pBase)
For j = tBase To tCols - (pCols - pBase)
bMatched = True
For ii = pBase To pRows
For jj = pBase To pCols
If TestArray(i + ii - pBase, j + jj - pBase) <> PatternArray(ii, jj) Then
bMatched = False
Exit For
End If
Next
If bMatched = False Then Exit For
Next
vResults(i, j) = IIf(bMatched, 1, 0)
If bMatched = True Then
MatchPattern = Array(i, j)
Exit Function
End If
Next
Next
End Function
Sub Test()
Dim cel As Range, rgPattern As Range, rgTest As Range
Dim v As Variant
Application.ScreenUpdating = False
With Worksheets("Sheet1")
Set rgPattern = .Range("A1:D4")
Set rgTest = .Range("H1:K22")
End With
v = MatchPattern(rgPattern.Value, rgTest.Value)
rgTest.Offset(0, rgTest.Columns.Count).Resize(UBound(v), UBound(v, 2)).Value = v
Macro1
End Sub
Function MatchPattern(PatternArray As Variant, TestArray As Variant) As Variant
Dim i As Long, ii As Long, j As Long, jj As Long, pBase As Long, pRows As Long, pCols As Long, _
tBase As Long, tRows As Long, tCols As Long
Dim vResults As Variant
Dim bMatched As Boolean
MatchPattern = "Not found"
pBase = LBound(PatternArray)
pRows = UBound(PatternArray)
pCols = UBound(PatternArray, 2)
tBase = LBound(TestArray)
tRows = UBound(TestArray)
tCols = UBound(TestArray, 2)
ReDim vResults(tBase To tRows, tBase To tCols - (pCols - pBase))
For i = tBase To tRows
For j = tCols - (pCols - pBase) To tBase Step -1
vResults(i, j) = "x"
Next
Next
For i = tBase To tRows - (pRows - pBase)
For j = tBase To tCols - (pCols - pBase)
bMatched = True
For ii = pBase To pRows
For jj = pBase To pCols
If TestArray(i + ii - pBase, j + jj - pBase) <> PatternArray(ii, jj) Then
bMatched = False
Exit For
End If
Next
If bMatched = False Then Exit For
Next
vResults(i, j) = IIf(bMatched, "Followup", "x")
Next
Next
MatchPattern = vResults
End Function
Private Sub Macro1()
Dim cel As Range
With Sheets("Sheet1")
.Range("L1:L4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Rows(1).Insert
.Range("G2:L23").Copy Sheets("Sheet2").Range("G1")
With .Range("G1:L23")
.AutoFilter
.AutoFilter Field:=6, Criteria1:="Followup"
.Copy Sheets("Sheet3").Range("G1")
.AutoFilter
End With
.Rows(1).Delete
End With
Sheets("Sheet3").Rows(1).Delete
End Sub
example-extract-Array-matchQ2836.xlsm
Option Explicit
Sub FindFollowup()
Dim MatchRange() As Variant, SearchRange() As Variant
Dim ws As Worksheet
Dim MatchRow As Long, MatchCol As Integer
Dim SearchRow As Long
Dim MatchUp As Integer, MatchDown As Integer
Set ws = Worksheets("Sheet1")
ws.Select
MatchRange = ws.Range("MatchRange")
SearchRange = ws.Range("SearchRange")
If UBound(SearchRange, 1) < UBound(MatchRange, 1) + 1 Or UBound(SearchRange, 2) < UBound(MatchRange, 2) + 2 Then
MsgBox "Check ranges, Stop"
Exit Sub
End If
If ws.AutoFilterMode = True Then
ws.AutoFilterMode = False
End If
For SearchRow = 2 To UBound(SearchRange, 1)
SearchRange(SearchRow, UBound(SearchRange, 2)) = "x"
If SearchRow > UBound(MatchRange, 1) + 1 Then
MatchUp = 0
For MatchRow = 1 To UBound(MatchRange, 1)
For MatchCol = 1 To UBound(MatchRange, 2)
If SearchRange(SearchRow - UBound(MatchRange, 1) - 1 + MatchRow, MatchCol + 1) = MatchRange(MatchRow, MatchCol) Then
MatchUp = MatchUp + 1
End If
Next MatchCol
Next MatchRow
End If
If SearchRow <= UBound(SearchRange, 1) - UBound(MatchRange, 1) + 1 Then
MatchDown = 0
For MatchRow = 1 To UBound(MatchRange, 1)
For MatchCol = 1 To UBound(MatchRange, 2)
If SearchRange(SearchRow - 1 + MatchRow, MatchCol + 1) = MatchRange(MatchRow, MatchCol) Then
MatchDown = MatchDown + 1
End If
Next MatchCol
Next MatchRow
End If
If MatchUp = UBound(MatchRange, 1) * UBound(MatchRange, 2) And MatchDown < UBound(MatchRange, 1) * UBound(MatchRange, 2) Then
SearchRange(SearchRow, UBound(SearchRange, 2)) = "Followup"
End If
Next SearchRow
ws.Range("SearchRange") = SearchRange
ws.Range("SearchRange").AutoFilter Field:=UBound(SearchRange, 2), Criteria1:="Followup"
End Sub
Array-match.xlsm
Sub FindMatches()
Dim WS As Worksheet
Dim WS2 As Worksheet
Dim MaxRow As Long, MaxRow2 As Long, I As Long, K As Long
Dim Foundit As Boolean
Dim sSearch As Range, cCell As Range
Set WS = ActiveSheet
Set WS2 = Sheets("Sheet2")
WS2.Cells.Delete
MaxRow = WS.UsedRange.Rows.Count
MaxRow2 = WS2.UsedRange.Rows.Count
Set sSearch = WS.Range("A1:D4")
For I = 1 To MaxRow
Foundit = True
For Each cCell In sSearch
If cCell.Value <> WS.Cells(I + cCell.Row - 1, cCell.Column + 7) Then
Foundit = False
Exit For
End If
Next cCell
If Foundit Then
WS.Cells(I, "M") = WS.Cells(I, "G")
WS.Cells(I + 1, "M") = WS.Cells(I + 1, "G")
WS.Cells(I + 2, "M") = WS.Cells(I + 2, "G")
WS.Cells(I + 3, "M") = WS.Cells(I + 3, "G")
End If
If WS.Cells(I, "M") = "" Then
WS.Range("G" & I & ":K" & I).Copy WS2.Cells(MaxRow2, 1)
MaxRow2 = MaxRow2 + 1
End If
Next I
MsgBox ("A total of " & MaxRow2 & " rows were copied to sheet2 successfully.")
End Sub
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.