Option Explicit
Const headerMAFFT As Long = 2
Const headerDeploy As Long = 9
Dim wsMAFFT As Worksheet, wsDeploy As Worksheet, wsCrossRef As Worksheet
Dim aMatch() As Long, aCopy() As Long
Dim aCleanMAFFT As Variant, aCleanDeploy As Variant
Sub MAFFT2Development()
Dim r As Range, rMAFFT As Range, rDeploy As Range
Dim i As Long, iMAFFT As Long, iDeploy As Long, iCopy As Long
Dim s As String
'set the sheets
Set wsMAFFT = Worksheets("MAFFT")
Set wsDeploy = Worksheets("Deployment")
Set wsCrossRef = Worksheets("CrossRef")
'build arrays with clean headers because the LF and spaces cause mis-match
With wsMAFFT
Set r = Range(.Cells(headerMAFFT, 1), .Cells(headerMAFFT, .Columns.Count).End(xlToLeft))
End With
aCleanMAFFT = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(r.Value))
For i = LBound(aCleanMAFFT) To UBound(aCleanMAFFT)
aCleanMAFFT(i) = Clean(CStr(aCleanMAFFT(i)))
Next i
With wsDeploy
Set r = Range(.Cells(headerDeploy, 1), .Cells(headerDeploy, .Columns.Count).End(xlToLeft))
End With
aCleanDeploy = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(r.Value))
For i = LBound(aCleanDeploy) To UBound(aCleanDeploy)
aCleanDeploy(i) = Clean(CStr(aCleanDeploy(i)))
Next i
'build array of col numbers with the MAFFT and Deployment fields to match
Set r = wsCrossRef.Cells(1, 1)
Set r = Range(r, r.End(xlDown)).Resize(, 2)
ReDim aMatch(1 To r.Rows.Count, 1 To 2)
For i = 2 To r.Rows.Count ' skip headers
aMatch(i, 1) = colNumber(Clean(r.Cells(i, 1).Value), aCleanMAFFT, headerMAFFT, wsMAFFT)
aMatch(i, 2) = colNumber(Clean(r.Cells(i, 2).Value), aCleanDeploy, headerDeploy, wsDeploy)
Next i
'build array of the column numbers to copy
Set r = wsCrossRef.Cells(1, 3)
Set r = Range(r, r.End(xlDown))
ReDim aCopy(1 To r.Rows.Count, 1 To 2)
For i = 2 To r.Rows.Count ' skip headers
aCopy(i, 1) = colNumber(Clean(r.Cells(i, 1).Value), aCleanMAFFT, headerMAFFT, wsMAFFT)
aCopy(i, 2) = colNumber(Clean(r.Cells(i, 1).Value), aCleanDeploy, headerDeploy, wsDeploy)
Next i
'set the data ranges
Set rMAFFT = wsMAFFT.Cells(headerMAFFT, 1).CurrentRegion 'starts in row 1, 1 = filler, 2 = col headers
Set rDeploy = wsDeploy.Cells(headerDeploy, 1).CurrentRegion 'starts in row 8, 8 = filler, 9 = col headers
'go down MMAFFT and check each group of aMatch against Deploy
Application.ScreenUpdating = False
For iMAFFT = 3 To rMAFFT.Rows.Count
For iDeploy = 3 To rDeploy.Rows.Count
If CheckMatchs(rMAFFT.Rows(iMAFFT), rDeploy.Rows(iDeploy)) Then
For iCopy = LBound(aCopy, 1) + 1 To UBound(aCopy, 1)
rMAFFT.Cells(iMAFFT, aCopy(iCopy, 1)).Copy rDeploy.Cells(iDeploy, aCopy(iCopy, 2))
Next iCopy
GoTo GetNextMAFFT
End If
Next iDeploy
s = "No match found for " & vbCrLf
For i = 2 To wsCrossRef.Cells(1, 1).End(xlDown).Row
s = s & wsCrossRef.Cells(i, 1) & vbCrLf
Next i
MsgBox s
GetNextMAFFT:
Next iMAFFT
Application.ScreenUpdating = True
End Sub
Private Function CheckMatchs(rMAFFT As Range, rDeploy As Range) As Boolean
Dim i As Long
Dim sMAFFT As String, sDeploy As String
CheckMatchs = False
For i = LBound(aMatch, 1) + 1 To UBound(aMatch, 1)
sMAFFT = rMAFFT.Cells(1, aMatch(i, 1))
sDeploy = rDeploy.Cells(1, aMatch(i, 2))
If LCase(sMAFFT) <> LCase(sDeploy) Then Exit Function
Next i
CheckMatchs = True
End Function
Private Function Clean(s As String) As String
s = Application.WorksheetFunction.Clean(s)
Clean = Replace(s, " ", vbNullString)
End Function
Private Function colNumber(colHeader As String, colArray As Variant, colRow As Long, sh As Worksheet) As Variant
Dim m As Long
m = 0
On Error Resume Next
m = Application.WorksheetFunction.Match(colHeader, colArray, 0)
On Error GoTo 0
If m > 0 Then
colNumber = m
Exit Function
End If
MsgBox colHeader & " not found in row " & colRow & " on " & sh.Name
colNumber = CVErr(xlErrValue)
End Function
MACRO: IF THEN Statement (Multiple Criteria Match then Copy)
Reply With Quote
Originally Posted by SamT
