I am trying to compare data across two sheets in the same workbook. First sheet has a list of individual addresses and the second has a list of address ranges where one column is the starting address range and the second column is the ending address range. for example
sheet1:
123 main st
230 main st
456 main st
Sheet2:
100 200 main st
400 500 main st
How do I find if an individual address falls within an address range? I have the below code that matches on the street name, but I need to add the criteria for the street number falling within that address range, otherwise it's not a match. In this example, sheet1 rows 1 and 3 is a match and sheet1 row 2 is not a match.
Sub matchcolumns()
Dim I, total, fRow As Integer
Dim found As Range
total = Sheets(1).Range("A" & Rows.Count).End(xlUp).row
For I = 2 To total
answer1 = Worksheets(2).Range("A" & I).Value
Set found = Sheets(1).Columns("H:H").Find(what:=answer1) 'finds a match
If Not found Is Nothing Then
Debug.Print "MATCH"
Else
Debug.Print "NO MATCH"
End If
Next I
End Sub
Loop through Sheet1 and check whether it exists in Sheet2. In this instance, MATCH or NO MATCH is written in the third column. Cheers.
Option Explicit
Public Sub check()
Dim vDataSheet As Worksheet
Dim vDataRow As Long
Dim vRefSheet As Worksheet
Dim vRefRow As Long
Dim vFound As Boolean
Set vDataSheet = Application.ActiveWorkbook.Sheets("Sheet1")
Set vRefSheet = Application.ActiveWorkbook.Sheets("Sheet2")
vDataRow = 1
While vDataSheet.Cells(vDataRow, 1) <> ""
vFound = False
vRefRow = 1
While vRefSheet.Cells(vRefRow, 1) <> "" And Not vFound
If vDataSheet.Cells(vDataRow, 1) >= vRefSheet.Cells(vRefRow, 1) And _
vDataSheet.Cells(vDataRow, 1) <= vRefSheet.Cells(vRefRow, 2) And _
vDataSheet.Cells(vDataRow, 2) = vRefSheet.Cells(vRefRow, 3) Then
vFound = True
End If
vRefRow = vRefRow + 1
Wend
If vFound Then
vDataSheet.Cells(vDataRow, 3) = "MATCH"
Else
vDataSheet.Cells(vDataRow, 3) = "NO MATCH"
End If
vDataRow = vDataRow + 1
Wend
End Sub
Sheet1 Before
Sheet2
Sheet1 After
#Mikku thanks I read the data as poorly formatted columns ... not as a single column. My mistake. Here is the updated code to work on single column data. I've made simplistic assumptions on data types (and left street numbers as strings given I've no idea on how they might really be structured) etc ... but works with the data examples used in question:
Option Explicit
Public Sub check()
Dim vDataSheet As Worksheet
Dim vDataRow As Long
Dim vStreetNumber As String
Dim vStreetName As String
Dim vRefSheet As Worksheet
Dim vRefRow As Long
Dim vFromNumber As String
Dim vToNumber As String
Dim vFirstSpace As Long
Dim vSecondspace As Long
Dim vRefName As String
Dim vFound As Boolean
Set vDataSheet = Application.ActiveWorkbook.Sheets("Sheet1")
Set vRefSheet = Application.ActiveWorkbook.Sheets("Sheet2")
vDataRow = 1
While vDataSheet.Cells(vDataRow, 1) <> ""
vStreetNumber = Left(vDataSheet.Cells(vDataRow, 1), InStr(1, vDataSheet.Cells(vDataRow, 1), " ") - 1)
vStreetName = Right(vDataSheet.Cells(vDataRow, 1), Len(vDataSheet.Cells(vDataRow, 1)) - InStr(1, vDataSheet.Cells(vDataRow, 1), " "))
vFound = False
vRefRow = 1
While vRefSheet.Cells(vRefRow, 1) <> "" And Not vFound
vFirstSpace = InStr(1, vRefSheet.Cells(vRefRow, 1), " ")
vFromNumber = Left(vRefSheet.Cells(vRefRow, 1), vFirstSpace - 1)
vSecondspace = InStr(vFirstSpace + 1, vRefSheet.Cells(vRefRow, 1), " ")
vToNumber = Mid(vRefSheet.Cells(vRefRow, 1), vFirstSpace + 1, vSecondspace - vFirstSpace - 1)
vRefName = Right(vRefSheet.Cells(vRefRow, 1), Len(vRefSheet.Cells(vRefRow, 1)) - vSecondspace)
If vStreetNumber >= vFromNumber And vStreetNumber <= vToNumber And _
vStreetName = vRefName Then
vFound = True
End If
vRefRow = vRefRow + 1
Wend
If vFound Then
vDataSheet.Cells(vDataRow, 2) = "MATCH"
Else
vDataSheet.Cells(vDataRow, 2) = "NO MATCH"
End If
vDataRow = vDataRow + 1
Wend
End Sub
Reference data on Sheet2
Matching outcome on Sheet1
Related
I have 10 attendance sheets in excel with only the names of present people. I want to find out which names are present in at least 7 sheets. How can I do this?
I know it is a terrible way to keep attendance and I wasn't the one who came up with it, I'm trying to salvage it.
Thanks in advance
Alright, this should do the trick. I threw it together so there are likely some efficiency improvements possible :)
Not sure what your structure is so I built this based on the simplest possible sheet, where there's a header row and students' names are shown when they attend. Students not in attendance are not listed. This probably doesn't match exactly but code should be easily tweaked. I can help if needed. You end up with an array called "arrGood" that contains the students and it'll pop up a message box telling you who met attendance or if no one did.
Option Explicit
Sub attendance()
'Set Variables
Dim sht As Integer, rw As Integer, pos As Integer, i As Integer, j As Integer, goodAttendance As Integer
Dim arrClass() As Variant, arrTransfer() As Variant, arrGood() As Variant
Dim strName As String, strStudents As String
Dim inArray As Boolean
goodAttendance = 2 'change this if you want to check a different number
'Initialize empty arrays
ReDim arrClass(0, 1)
ReDim arrGood(0)
For sht = 1 To ThisWorkbook.Worksheets.Count 'loop through worksheets
For rw = 2 To ThisWorkbook.Worksheets(sht).Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'loop through rows starting with 2 (assuming there's a header row)
inArray = False
strName = ThisWorkbook.Sheets(sht).Cells(rw, 1).Value 'change this cell if searching for student names outside the first column
'This section only triggers on the first run and adds the first student with attendance of 1
If arrClass(0, 0) = "" Then
arrClass(0, 0) = strName
arrClass(0, 1) = 1
inArray = True
Else
For pos = 0 To UBound(arrClass()) 'loop through array
'check if student is already in array. Add 1 to their attendance if so
If arrClass(pos, 0) = strName Then
inArray = True
arrClass(pos, 1) = arrClass(pos, 1) + 1
End If
Next pos
End If
If inArray = False Then 'new student not in array
'Workaround to redim multidimensional array
arrTransfer = arrClass
ReDim arrClass(0 To UBound(arrClass) + 1, 1)
For i = 0 To UBound(arrTransfer)
For j = 0 To 1
arrClass(i, j) = arrTransfer(i, j)
Next j
Next i
'Add new student to array and set their attendance to 1
arrClass(UBound(arrClass), 0) = strName
arrClass(UBound(arrClass), 1) = 1
End If
Next rw
Next sht
'Check for students with good attendance
For i = 0 To UBound(arrClass)
If arrClass(i, 1) >= goodAttendance Then
'Add first student
If arrGood(0) = "" Then
arrGood(0) = arrClass(i, 0)
'Add subsequent students
Else
ReDim Preserve arrGood(0 To UBound(arrGood) + 1)
arrGood(UBound(arrGood)) = arrClass(i, 0)
End If
strStudents = strStudents + arrClass(i, 0) + ", "
End If
Next i
'Display students meeting criteria
If Len(strStudents) > 0 Then
strStudents = Left(strStudents, Len(strStudents) - 2)
MsgBox ("Students with more than " & goodAttendance & " attendances: " & strStudents)
Else
MsgBox ("No students had at least " & goodAttendance & " attendances.")
End If
End Sub
I am trying to copy data from one workbook to another based on the values contained in cells in the source workbook that matches the same values in the target workbook. For example, I have a table (Table1) that has four columns say, A1:D5. One of these columns (column A) contains account numbers that match similar account numbers located on another workbook (also in column A). I am trying to find a code that looks through the table (Table1) in the source workbook via the account number column, and if the account number matches the account number in the target workbook, copy and paste the cells on that row in specific locations to the target workbook. Is this possible?
I hope that makes sense. I have looked all over on how to structure such a code, and I was not able to find anything to start the process for this logic.
Any help will be very appreciative.
Thank you
Even if your question is about doing this in VBA, I'm just going to mention that what you are trying to do seems like it could also be done with Power Query.
That being said, if you were to use VBA for this, you would have to use the Match function to find where your rows match and then copy the data from the source to the destination table.
I've adapted the code I provided to this question to better serve your specific needs. One of the things I've done is to add an optional argument called DoOverwrite and set it to false. This will make sure that the information from one row won't be overwritten by another row later down the road.
Sub TableJoinTest()
'Those table columns will have to match for the 2 lines to be a match
Dim MandatoryHeaders() As Variant
MandatoryHeaders = Array("Account Number")
Dim SourceTableAnchor As Range
Set SourceTableAnchor = Workbooks("SourceWorkbook.xlsx").Sheets("Sheet1").Range("A1")
Dim TargetTableAnchor As Range
Set TargetTableAnchor = Workbooks("TargetWorkbook.xlsx").Sheets("Sheet1").Range("A1")
TableJoin _
SourceTableAnchor:=SourceTableAnchor, _
TargetTableAnchor:=TargetTableAnchor, _
MandatoryHeaders:=MandatoryHeaders, _
AddIfMissing:=False, _
IsLogging:=False, _
DoOverwrite:=False
End Sub
Sub TableJoin( _
SourceTableAnchor As Range, _
TargetTableAnchor As Range, _
MandatoryHeaders As Variant, _
Optional OtherHeaders As Variant, _
Optional AddIfMissing As Boolean = False, _
Optional IsLogging As Boolean = False, _
Optional DoOverwrite As Boolean = True)
'''''''''''''''''''''''''''''''''''''''
'Definitions
'''''''''''''''''''''''''''''''''''''''
Dim srng As Range, trng As Range
Set srng = SourceTableAnchor.CurrentRegion
Set trng = TargetTableAnchor.CurrentRegion
Dim sHeaders As Range, tHeaders As Range
Set sHeaders = srng.Rows(1)
Set tHeaders = trng.Rows(1)
'Store in Arrays
Dim sArray() As Variant 'prefix s is for Source
sArray = ExcludeRows(srng, 1).Value2
Dim tArray() As Variant 'prefix t is for Target
tArray = ExcludeRows(trng, 1).Value2
Dim sArrayHeader As Variant
sArrayHeader = sHeaders.Value2
Dim tArrayHeader As Variant
tArrayHeader = tHeaders.Value2
'Find Column correspondance
Dim sMandatoryHeadersColumn As Variant
ReDim sMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim tMandatoryHeadersColumn As Variant
ReDim tMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim k As Long
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), sArrayHeader, 0)
tMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), tArrayHeader, 0)
Next k
Dim sOtherHeadersColumn As Variant
ReDim sOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
Dim tOtherHeadersColumn As Variant
ReDim tOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
sOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), sArrayHeader, 0)
tOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), tArrayHeader, 0)
Next k
'Merge mandatory headers into one column (aka the helper column method)
Dim i As Long, j As Long
Dim sHelperColumn() As Variant
ReDim sHelperColumn(LBound(sArray, 1) To UBound(sArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sHelperColumn(i, 1) = sHelperColumn(i, 1) & sArray(i, sMandatoryHeadersColumn(j))
Next j
Next i
Dim tHelperColumn() As Variant
ReDim tHelperColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(tArray, 1) To UBound(tArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
tHelperColumn(i, 1) = tHelperColumn(i, 1) & tArray(i, tMandatoryHeadersColumn(j))
Next j
Next i
'Find all matches
Dim MatchList() As Variant
Dim LoggingColumn() As String
ReDim LoggingColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
ReDim MatchList(LBound(tArray, 1) To UBound(tArray, 1))
For j = LBound(tArray, 1) To UBound(tArray, 1)
If sHelperColumn(i, 1) = tHelperColumn(j, 1) Then
MatchList(j) = 1
End If
Next j
'Get the row number for the match
Dim MatchRow As Long
Select Case Application.Sum(MatchList)
Case Is > 1
'Need to do more matching
Dim MatchingScoresList() As Long
ReDim MatchingScoresList(1 To UBound(tArray, 1))
Dim m As Long
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
For m = LBound(tArray, 1) To UBound(tArray, 1)
If tArray(m, sOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k)) Then
MatchingScoresList(m) = MatchingScoresList(m) + 2 ^ (UBound(OtherHeaders) - k)
End If
Next m
Next k
'Get the max score position
Dim MyMax As Long
MyMax = Application.Max(MatchingScoresList)
If Application.Count(Application.Match(MatchingScoresList(), Array(MyMax), 0)) > 1 Then
MsgBox "Error: can't determine how to match row " & i & " in source table"
Exit Sub
Else
MatchRow = Application.Match(MyMax, MatchingScoresList, 0)
End If
Case Is = 1
MatchRow = Application.Match(1, MatchList, 0)
Case Else
Dim nArray() As Variant, Counter As Long
If AddIfMissing Then
MatchRow = 0
Counter = Counter + 1
ReDim nArray(1 To Counter, 1 To UBound(tArray, 2))
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
nArray(Counter, tMandatoryHeadersColumn(k)) = sArray(i, sMandatoryHeadersColumn(k))
Next k
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
nArray(Counter, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
Next k
Else
MsgBox "Error: Couldn't find a match for data row #" & i
Exit Sub
End If
End Select
'Logging and assigning values
If MatchRow > 0 Then
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
If tArray(MatchRow, tOtherHeadersColumn(k)) <> sArray(i, sOtherHeadersColumn(k)) Then
'Logging
If IsLogging And DoOverwrite Then LoggingColumn(MatchRow, 1) = LoggingColumn(MatchRow, 1) & _
IIf(LoggingColumn(MatchRow, 1) <> "", ", ", "") & _
tHeaders.Cells(1, tOtherHeadersColumn(k)) & " : " & _
tArray(MatchRow, tOtherHeadersColumn(k)) & _
" -> " & sArray(i, sOtherHeadersColumn(k))
'Assign new value
If DoOverwrite Or tArray(MatchRow, tOtherHeadersColumn(k)) = VbNullString Then
tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
End If
End If
Next k
End If
Next i
'Write arrays to sheet
ExcludeRows(trng, 1).Value2 = tArray
With trng.Parent
If IsArrayInitialised(nArray) And AddIfMissing Then
.Cells(trng.Cells(1, 1).Row + trng.Rows.Count, trng.Cells(1, 1).Column).Resize(UBound(nArray, 1), UBound(nArray, 2)).Value2 = nArray
End If
If IsLogging Then
.Cells(trng.Cells(1, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count) = "Changes"
.Cells(trng.Cells(2, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count).Resize(UBound(LoggingColumn, 1), 1).Value2 = LoggingColumn
End If
End With
End Sub
And also add these functions inside your VBA project to as they are used in the procedure above.
Function IsArrayInitialised(ByRef A() As Variant) As Boolean
On Error Resume Next
IsArrayInitialised = IsNumeric(UBound(A))
On Error GoTo 0
End Function
Function ExcludeRows(MyRng As Range, StartRow As Long, Optional EndRow As Long = -1) As Range
'PURPOSE: Exclude one or more consecutives rows from an existing range
Dim Afterpart As Range, BeforePart As Range
If StartRow < 1 Or EndRow > MyRng.Rows.Count Then Set ExcludeRows = Nothing
If StartRow = 1 And EndRow = MyRng.Rows.Count Then Set ExcludeRows = Nothing
If EndRow = -1 Then EndRow = StartRow
If EndRow < MyRng.Rows.Count Then
With MyRng.Parent
Set Afterpart = .Range(MyRng.Cells(EndRow + 1, 1), MyRng.Cells(MyRng.Rows.Count, MyRng.Columns.Count))
End With
End If
If StartRow > 1 Then
With MyRng.Parent
Set BeforePart = .Range(MyRng.Cells(1, MyRng.Cells(1, 1).Column), MyRng.Cells(StartRow - 1, MyRng.Columns.Count))
End With
End If
Set ExcludeRows = Union2(True, BeforePart, Afterpart)
End Function
Public Function Union2(IgnoreEmptyRange As Boolean, ParamArray RangeArray() As Variant) As Range
'PURPOSE: Samae as Application.Union but allows some range object to be Empty
Dim V As Variant
Dim Rng As Range
For Each V In RangeArray
Do
If VarType(V) = vbEmpty Then Exit Do
Set Rng = V
If Not Union2 Is Nothing Then
Set Union2 = Union(Union2, Rng)
ElseIf Not Rng Is Nothing Then
Set Union2 = Rng
End If
Loop While False
Next
End Function
I have multiple worksheets and each sheet contains skill details.
Sample data
Skills Name
Programs(C#, VB, Python) C#
OS(Windows, Linux)
DB(Oracle, SQL) Oracle
My requirement is, if user put skills as "Programs(C#, VB, Python)", then return next cell value i.e. "C#"
My code.
Private Sub BtnReport_Click()
Dim SkillName As String
Dim SkillRng As Range
Dim rng As Range
'Dim nextblankrow As Long
'Dim lastrow As Long
Dim x As Long
Dim y As Long
Dim val As String
SkillName = ActiveWorkbook.Worksheets("Admin").Range("L4")
If SkillName = "" Then
MsgBox "Select a skill name"
Exit Sub
End If
'Sheets(2).Select
'Set rng = Sheets(2).Range("B14:B100").Find(What:=SkillName)
'MsgBox rng.Value
Sheets("Report").Select
Sheets("Report").Cells.ClearContents
Sheets("Report").Cells(1, 1) = "Skill Name"
Sheets("Report").Cells(1, 2) = "Resource"
'''''For i = 1 To Sheets.Count - 1
''''' Set rng = Sheets(i).Range("B14:C100")
''''' Set SkillRng = rng.Find(What:=SkillName)
''''' If Not SkillRng Is Nothing Then
''''' Sheets("Report").Cells(i + 1, 1) = SkillRng.Value
''''' MsgBox rng.Cells.Value
'''''' Sheets("Report").Cells(i + 1, 2) = rng.Offset(RowoffSet = 1, Columnoffset = 2).Value
'''''' Sheets("Report").Cells(i + 1, 2) = SkillRng.Cells(Selection.Row, Selection.Column + 1).Value
''''' Sheets("Report").Cells(i + 1, 3) = ActiveWorkbook.Worksheets(i).name
''''' End If
'''''Next i
Set rng = Sheets(2).Range("B14:C100")
Set SkillRng = rng.Find(What:=SkillName)
For x = 1 To rng.Rows.Count
For y = 1 To rng.Columns.Count
If rng.Cells(x, y) = SkillRng Then
' Sheets("Report").Cells(2, 2) = rng.Cells(x, y + 1)
MsgBox SkillRng
MsgBox x
MsgBox y
val = Cells(x, y).Value
' val = SkillRng
MsgBox val
End If
Next y
Next x
I believe this will give you everything with little editing for sheet numbers and intended Report cell values
There is difference between sheets and worksheets. Sheets also include charts. So for your purpose use worksheets. Also, you have to skip the Report and Admin Worksheets for evaluation in the loop. If your report and Admin worksheets are (1) and (2) then start loop from 3. If you loop also evaluates these sheets and if it finds skillname in range to find (rng) in these sheets values from these sheets will also appear in your report.
Private Sub BtnReport_Click()
Dim SkillName As String
Dim SkillRng As Range
Dim rng As Range
SkillName = ActiveWorkbook.Worksheets("Admin").Range("L4")
If SkillName = "" Then
MsgBox "Select a skill name"
Exit Sub
End If
Sheets("Report").Select
Sheets("Report").Cells.ClearContents
Sheets("Report").Cells(1, 1) = "Skill Name"
Sheets("Report").Cells(1, 2) = "Resource"
For i = 1 To Worksheets.Count
Set rng = Worksheets(i).Range("B14:C100")
Set SkillRng = rng.Find(What:=SkillName)
k = Sheets("Report").Range("A1").CurrentRegion.Rows.Count + 1
If Not SkillRng Is Nothing Then
Sheets("Report").Cells(k, 1) = SkillName
Sheets("Report").Cells(k, 2) = SkillRng.Value
Sheets("Report").Cells(k, 3) = SkillRng.offset(0,1)
Sheets("Report").Cells(k, 4) = Worksheets(i).name
End If
Next i
End sub
Good morning! I'm trying to create a VBA function and appreciate any help you can provide to get me on the right track. In short, for each value in Column A of Worksheet Exams, I need to concatenate all the unique values in Column B in Worksheet Findings in which Column A of Worksheet Exams = Column A of Worksheet Findings. I'm struggling with where to start, and can't seem to find any good guidance. In advance, thank you for your help. Much appreciated.
Started with this to get my bearings on the concat... I know the & ExamID portion is wrong, but I'm not sure what code I need there to Concatenate with the next instance of that RX721502:
Dim ExamID As Range
Dim strConcat As String
Dim i As Integer
i = 2
Do While Cells(i, 1).Value <> ""
For Each ExamID In Range("A2:A10000")
If InStr(ExamID.Value, "RX721502") > 0 Then
Cells(i, 18).Value = ActiveCell.Offset(0, 10) & ", " & ExamID
End If
Next ExamID
Cells(2, 18) = Trim(Cells(2, 18))
i = i + 1
Loop
G
try the following code, it puts the Concatenate string of Cities in Worksheet SourceExams, Column 2.
Sub use_VLookup()
Dim conOG As String
Dim SourceExams As Worksheet
Dim SourceFindings As Worksheet
Dim lastrow, lastrow2 As Long
Dim rowfound As Long
Dim Vlookup_result As Variant
Set SourceExams = ActiveWorkbook.Sheets("Source-Exams")
Set SourceFindings = ActiveWorkbook.Sheets("Source-Findings")
lastrow = SourceExams.UsedRange.Rows.count
lastrow2 = SourceFindings.UsedRange.Rows.count
For i = 2 To lastrow
j = 2
While j <= lastrow2
' search Worksheet Cities workcheet for match on Column A, and return the value in column B
Vlookup_result = Application.VLookup(SourceExams.Cells(i, 1), SourceFindings.Range(SourceFindings.Cells(j, 1), SourceFindings.Cells(lastrow2, 2)), 2, False)
If IsError(Vlookup_result) Then
' do nothing , you can add erro handling, but I don't think it's necesary
Else
conOG = conOG & ", " & Application.WorksheetFunction.VLookup(SourceExams.Cells(i, 1), SourceFindings.Range(SourceFindings.Cells(j, 1), SourceFindings.Cells(lastrow2, 2)), 2, False)
rowfound = Application.WorksheetFunction.Match(SourceExams.Cells(i, 1), SourceFindings.Range(SourceFindings.Cells(j, 1), SourceFindings.Cells(lastrow2, 1)), 0)
End If
j = j + rowfound
' if first found go to row 3
If j <= 2 Then j = 3
Wend
SourceExams.Cells(i, 2) = conOG
conOG = ""
Next i
End Sub
I have 100 names in one column. And next to each name in the next cell is a numerical value that the name is worth.There are 6 positions in a company that each name could potentially hold. And that is also in a cell next to each name.
So the spreadsheet looks something like this.
John Smith Lawyer $445352
Joe Doe Doctor $525222
John Doe Accountant $123192
etc....
I want excel to give me 10 people who make a combined amount between 2 and 3 million dollars. But I require that 2 of the people be doctors 2 be lawyers and 2 be accountants etc. How would I create this?
I set up sheet 1 with the following data:
Goal:
Return 10 people
Salary between 1000000 and 6000000 range
Min 2 each doc, lawyer, accountant
Run this Macro:
Sub macro()
Dim rCell As Range
Dim rRng As Range
Dim rangelist As String
Dim entryCount As Long
Dim totalnum As Long
Set rRng = Sheet1.Range("A1:A12")
Dim OccA As String
Dim OccCntA As Long
Dim OccASalmin As Long
Dim OccASalmax As Long
Dim OccB As String
Dim OccCntB As Long
Dim OccBSalmin As Long
Dim OccBSalmax As Long
Dim OccC As String
Dim OccCntC As Long
Dim OccCSalmin As Long
Dim OccCSalmax As Long
'Set total number of results to return
totalnum = 10
'Set which occupations that must be included in results
OccA = "Accountant"
OccB = "Doctor"
OccC = "Lawyer"
'Set minimum quantity of each occupation to me returned in results
OccCntA = 2
OccCntB = 2
OccCntC = 2
'Set min and max salary ranges to return for each occupation
OccASalmin = 1000000
OccASalmax = 6000000
OccBSalmin = 1000000
OccBSalmax = 6000000
OccCSalmin = 1000000
OccCSalmax = 6000000
'Get total number of entries
entryCount = rRng.Count
'Randomly get first required occupation entries
'Return list of rows for each Occupation
OccAList = PickRandomItemsFromList(OccCntA, entryCount, OccA, OccASalmin, OccASalmax)
OccBList = PickRandomItemsFromList(OccCntB, entryCount, OccB, OccBSalmin, OccBSalmax)
OccCList = PickRandomItemsFromList(OccCntC, entryCount, OccC, OccCSalmin, OccCSalmax)
For Each i In OccAList
If rangelist = "" Then
rangelist = "A" & i
Else
rangelist = rangelist & "," & "A" & i
End If
Next i
For Each i In OccBList
If rangelist = "" Then
rangelist = "A" & i
Else
rangelist = rangelist & "," & "A" & i
End If
Next i
For Each i In OccCList
If rangelist = "" Then
rangelist = "A" & i
Else
rangelist = rangelist & "," & "A" & i
End If
Next i
'Print the rows that match criteria
Dim rCntr As Long
rCntr = 1
Dim nRng As Range
Set nRng = Range(rangelist)
For Each j In nRng
Range(j, j.Offset(0, 2)).Select
Selection.Copy
Range("E" & rCntr).Select
ActiveSheet.Paste
rCntr = rCntr + 1
Next j
'Get rest of rows randomly and print
OccList = PickRandomItemsFromListB(totalnum - rCntr + 1, entryCount, rangelist)
For Each k In OccList
Set Rng = Range("A" & k)
Range(Rng, Rng.Offset(0, 2)).Select
Selection.Copy
Range("E" & rCntr).Select
ActiveSheet.Paste
rCntr = rCntr + 1
Next k
End Sub
Function PickRandomItemsFromListB(nItemsToPick As Long, nItemsTotal As Long, avoidRng As String)
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
Set isect = Application.Intersect(Range("A" & idx(i)), Range(avoidRng))
If booIndexIsUnique = True And isect Is Nothing Then
Exit Do
End If
Loop
varRandomItems(i) = idx(i)
Next i
PickRandomItemsFromListB = varRandomItems
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.
End Function
Function PickRandomItemsFromList(nItemsToPick As Long, nItemsTotal As Long, Occ As String, Salmin As Long, Salmax As Long)
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
If booIndexIsUnique = True And Range("B" & idx(i)).Value = Occ And Range("B" & idx(i)).Offset(0, 1).Value >= Salmin And Range("B" & idx(i)).Offset(0, 1).Value <= Salmax Then
Exit Do
End If
Loop
varRandomItems(i) = idx(i)
Next i
PickRandomItemsFromList = varRandomItems
End Function
Results are printed in column E with the first results meeting the criteria. After those, the rest are random but don't repeat the previous ones:
I'm not doing very much error checking such as what happens if there are not 2 doctors or not enough entries left to meet the required number of results. You'll have to fine tune it for your purposes. You'll probably also want to set up the inputs as a form so you don't have to mess with code every time you change your criteria.