Related
I have a question regarding finding and detecting gaps per row in VBA excel.
The dificult part is gaps that start on Friday and run until Thursday (FTGaps) need to be added up seperately and gaps starting on other days have to be counted seperately.
So for instance in the picture the result from the first row has to be: 1 FTGap and 1 Gap
And the second row has to be 1 FTGap.
But if there is a empty cell earlier in the row it has to be counted as a different gap.
So for instance the following rows output is 2 gaps and 1 FTGap.
I hope my question is clear.
Thanks in advance
What I tried
For Row = 3 To Worksheets("Kalender2").UsedRange.Rows.Count
GapDays = 0
FTGapDays = 0
For col = 2 To 55 'Worksheets("Kalender2").Cells(2,
Columns.Count).End(xlToLeft).Column
If Worksheets("Kalender2").Cells(Row, col) = "0" And
Worksheets("Kalender2").Cells(2, col).Value = "Friday" Then
FTGapDays = FTGapDays + 1
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays <> 0 Then
FTGapDays = FTGapDays + 1 'doortellen gap startend op
vrijdag
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays = 0 Then 'And Worksheets("Kalender2").Cells(2, Col).Value <>
"Friday" Then
GapDays = GapDays + 1 'eerste lege cel andere dag dan
vrijdag
End If
Next col
If col = 54 Then
Call EndGap
End If
Call EndGap
Next Row
'
And then the second Sub Endgap():
If FTGapDays <> 0 Then
If FTGapDays < 7 Then
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 7 And FTGapDays < 14 Then
FTGaps = FTGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 14 And FTGapDays < 21 Then
FTGaps = FTGaps + 2
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 21 And FTGapDays < 28 Then
FTGaps = FTGaps + 3
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 28 And FTGapDays < 35 Then
FTGaps = FTGaps + 4
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 35 And FTGapDay < 42 Then
FTGaps = FTGaps + 5
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays = 42 Then
FTGaps = FTGaps + 6
LegGaps = LegGaps + 2
End If
End If
End Sub
Please, test the next solution. It uses a kind of trick: Dividing a number to 0 in a formula will return an error. So, such a formula is placed two rows down after the last, then using SpecialCells(xlCellTypeFormulas, xlErrors) creates a discontinuous range of the gaps and process it. The processing result is returned two columns to the right of the last column. In the first such a column the 'Gaps' and in the second one 'FTGap'. The code assumes that the row keeping the days name is the second and the zero (0) seen in your pictures are values not string as you tried using in your code:
Sub extractGaps()
Dim sh As Worksheet, lastR As Long, lastCol As Long, rng As Range, arrCount, arrRows, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
If sh.Range("A" & lastR).HasFormula Then
If left(sh.Range("A" & lastR).Formula, 3) = "=1/" Then
sh.rows(lastR).EntireRow.ClearContents
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
End If
End If
lastCol = sh.cells(2, sh.Columns.count).End(xlToLeft).column
ReDim arrCount(1 To lastR - 2, 1 To lastCol)
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
For i = 3 To lastR
arrRows = countGaps(sh.Range("A" & i, sh.cells(i, lastCol)), lastR, lastCol)
arrCount(i - 2, 1) = arrRows(0): arrCount(i - 2, 2) = arrRows(1)
Next i
sh.Range("A" & lastR + 2).EntireRow.ClearContents
sh.cells(3, lastCol + 2).Resize(UBound(arrCount), 2).value = arrCount
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Function countGaps(rngR As Range, lastR As Long, lastCol As Long) As Variant
Dim sh As Worksheet: Set sh = rngR.Parent
Dim rngProc As Range, i As Long, A As Range, FTGap As Long, Gap As Long
Dim boolGap As Boolean, bigGaps As Double, mtchFr
Set rngProc = sh.Range(sh.cells(lastR + 2, 1), sh.cells(lastR + 2, lastCol)) 'a range where to place a formula returnig errors deviding by 0...
rngProc.Formula = "=1/" & rngR.Address
On Error Resume Next
Set rngProc = rngProc.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If rngProc.cells.count = rngR.cells.count Then
If IsNumeric(rngProc.cells(1)) Then countGaps = Array(0, 0): Exit Function
End If
If rngProc Is Nothing Then countGaps = Array(0, 0): Exit Function 'in case of no gaps...
Gap = 0: FTGap = 0: Debug.Print rngProc.Areas.count
For Each A In rngProc.Areas
Debug.Print sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)).Address: 'Stop
If A.cells.count < 7 Then
Gap = Gap + 1
ElseIf A.cells.count = 7 Then
If sh.cells(2, A.cells(1).column).value = "Friday" Then
FTGap = FTGap + 1
Else
Gap = Gap + 1
End If
Else 'for more than 7 empty cells:
'set the Friday day position in the empty cells range/area:
mtchFr = Application.match("Friday", sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)), 0)
If A.Columns.count - mtchFr < 6 Then 'no any FTGap existing:
Gap = Gap + 1
ElseIf A.cells.count - mtchFr = 6 Then 'fix a FTGap
Gap = Gap + 1: FTGap = FTGap + 1
Else
bigGaps = ((A.cells.count - mtchFr) - i + 1) / 7
FTGap = FTGap + Int(bigGaps)
If mtchFr <> 1 Then Gap = Gap + 1 'the gap before Friday
If A.cells.count - i + 1 - Int(bigGaps) * 7 > 0 Then Gap = Gap + 1
End If
End If
Next A
countGaps = Array(Gap, FTGap)
End Function
Problem
We have a range (apparently "B3:BC" & UsedRange.Rows.count). The range is preceded by a row (B2:BC2) containing days of the week repeated in consecutively order: Monday, Tuesday, etc.
Cells for each row in the range contain either a 0 or some other value (integer? does not matter much). Consecutive 0's in a row (length > 0) are treated as a gap. We have two types of gaps:
a regular Gap: a range of consecutive 0's of any length > 0;
a Friday-through-to-Thursday-Gap (FtGap): a range of consecutive 0's, that starts on a Friday and ends on Thursday (length = 7).
For each row we want to count the number of Gaps and FtGaps, taking into account the following condition: a range of consecutive 0's that qualifies as a FtGap should not also be counted as a regular Gap.
Solution
To solve this problem, I've used range B3:BC20 for the data. Cells in this range have been populated randomly with either 0's or 1's (but this value could be anything) using =IF(RAND()>0.8,0,1). My row with "days of the week" starts with a "Monday", but this should make no difference.
I've used the following method:
Create two arrays for row days and the data.
Loop through each row array with nested loop through cols to access all cells per row.
On each new 0, increment the total Gap count (GapTrack) by 1. For each new 0, increment a variable (GapTemp) by 1 that tracks the length of the Gap. Reset GapTemp on the next non-0.
For each 0 on a "Friday", start incrementing a variable FtTemp. We keep checking if its value (length) has reached any multiple of 7. When it does, we increment the Ft count (FtTrack) by 1.
On each new non-0, check if FtTemp mod 7 = 0 and GapTemp Mod 7 = 0 and GapTemp > 0. If True, we will have added a regular Gap to our total count of the same length as one or more FtTemps. This violates the condition mentioned above. Remedy this by decrementing GapTrack by 1.
At the end of the row, we wrap GapTrack and FtTrack inside an array, assign it to a new key in a dictionary. At the start of the next row, we reset all our variables, and restart the count.
When the loop is finished, we end up with a dictionary that contains all our counts per row. We write this data away somewhere.
Code as follows with some further notes on what is happening. N.B. I've used "Option Explicit" to force proper declaration of all our variables.
Option Explicit
Sub CountGaps()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Kalender2")
Dim rngDays As Range, rngData As Range
Dim arrDays As Variant, arrData() As Variant
Set rngDays = ws.Range("Days") 'Named range referencing $B$2:$BC$2 in "Kalender2!"
Set rngData = ws.Range("Data") 'Named range referencing $B$3:$BC$20 in "Kalender2!"
'populate arrays with range values
arrDays = rngDays.Value 'dimensions: arrDays(1, 1) to arrDays(1, rngDays.Columns.Count)
arrData = rngData.Value 'dimensions: arrData(1, 1) to arrData(rngData.rows.Count, rngData.Columns.Count)
'declare ints for loop through rows (i) and cols (i) of arrData
Dim i As Integer, j As Integer
'declare booleans to track if we are inside a Gap / FtGap
Dim GapFlag As Boolean, FtFlag As Boolean
'declare ints to track current Gap count (GapTemp), sum Gap count (GapTrack), and same for Ft
Dim GapTemp As Integer, GapTrack As Integer, FtTemp As Integer, FtTrack As Integer
'declare dictionary to store GapTrack and FtTrack for each row
'N.B. in VBA editor (Alt + F11) go to Tools -> References, add "Microsoft Scripting Runtime" for this to work
Dim dict As New Scripting.Dictionary
'declare int (counter) for iteration over range to fill with results
Dim counter As Integer
'declare key for loop through dict
Dim key As Variant
'-----
'start procedure: looping through arrData rows: (arrData(i,1))
For i = LBound(arrData, 1) To UBound(arrData, 1)
'for each new row, reset variables to 0/False
GapTemp = 0
GapTrack = 0
GapFlag = False
FtTemp = 0
FtTrack = 0
FtFlag = False
'nested loop through arrData columns: (arrData(i,2))
For j = LBound(arrData, 2) To UBound(arrData, 2)
If arrData(i, j) = 0 Then
'cell contains 0: do stuff
If arrDays(1, j) = "Friday" Then
'Day = "Friday", start checking length Ft gap
FtFlag = True
End If
'increment Gap count
GapTemp = GapTemp + 1
If GapFlag = False Then
'False: Gap was not yet added to Total Gap count;
'do this now
GapTrack = GapTrack + 1
'toggle Flag to ensure continuance of 0 range will not be processed anew
GapFlag = True
End If
If FtFlag Then
'We are inside a 0 range that had a Friday in the preceding cells
'increment Ft count
FtTemp = FtTemp + 1
If FtTemp Mod 7 = 0 Then
'if True, we will have found a new Ft Gap, add to Total Ft count
FtTrack = FtTrack + 1
'toggle Flag to reset search for new Ft Gap
FtFlag = False
End If
End If
Else
'cell contains 1: evaluate variables
If (FtTemp Mod 7 = 0 And GapTemp Mod 7 = 0) And GapTemp > 0 Then
'if True, then it turns out that our last range STARTED with a "Friday" and continued through to a "Thursday"
'if so, we only want to add this gap to the Total Ft count, NOT to the Total Gap count
'N.B. since, in fact, we will already have added this range to the Total Gap count, we need to retract that step
'Hence: we decrement Total Gap count
GapTrack = GapTrack - 1
End If
'since cell contains 1, we need to reset our variables again (except of course the totals)
GapTemp = 0
GapFlag = False
FtTemp = 0
FtFlag = False
End If
Next j
'finally, at the end of each row, we assign the Total Gap / Ft counts as an array to a new key (i = row) in our dictionary
dict.Add i, Array(GapTrack, FtTrack)
Next i
'we have all our data now stored in the dictionary
'example of how we might write this data away in a range:
rngDays.Columns(rngData.Columns.Count).Offset(0, 1) = "Gaps" 'first col to the right of data
rngDays.Columns(rngData.Columns.Count).Offset(0, 2) = "FtGaps" 'second col to the right of data
'set counter for loop through keys
counter = 0
For Each key In dict.Keys
'resize each cell in first col to right of data to fit "Array(GapTrack, FtTrack)" and assign that array to its value ("dict(key)")
rngData.Columns(rngData.Columns.Count).Offset(counter, 1).Resize(1, 2).Value = dict(key)
'increment counter for next cell
counter = counter + 1
Next key
End Sub
Snippet of result:
Let me know if you experience any difficulties with implemention.
Please help
I am trying to perform the following:
I have an excel file 'A' with 50000 rows.
I am creating another excel 'B' with 150 rows.
The 150 rows are picked from file 'A'.
The row selection criteria is based on values of 5 different columns as this set
First I want to make sure I select the rows with all different combination of these 5 columns
If I run out of combinations then I can pick combination which are repeated as have to reach the 150
What I have achieved till now is selecting 150 random rows from excel A and pasted in excel B
records = 150
With DataWs
SourceLastRow = .Cells(.Rows.count, "B").End(xlUp).Row
.Rows(1).Copy DestinationWs.Cells(DestLastRow, "A")
ar = RandomNumber(2, SourceLastRow, Records)
For r = 2 To UBound(ar)
DestLastRow = DestLastRow + 1
.Rows(ar(r)).Copy DestinationWs.Cells(DestLastRow, "A")
Next r
End With
Function RandomNumber(Bottom As Long, Top As Long, Amount As Long) As Variant
Dim i As Long, r As Long, temp As Long
ReDim iArr(Bottom To Top) As Long
For i = Bottom To Top: iArr(i) = i: Next i
For i = 1 To Amount
r = Int(Rnd() * (Top - Bottom + 1 - (i - 1))) _
+ (Bottom + (i - 1))
temp = iArr(r): iArr(r) = iArr(Bottom + i - 1): _
iArr(Bottom + i - 1) = temp
Next i
ReDim Preserve iArr(Bottom To Bottom + Amount - 1)
RandomNumber = iArr
End Function
This is maybe a bit complex but worked for me:
Sub PickRows()
Const COPY_ROWS As Long = 150
Dim dict As Object, data, DataWS As Worksheet, DestWS As Worksheet
Dim numCopied As Long, r As Long, k As String, destRow As Long
Dim combo As Long, keys, col As Collection, theRow As Long, t
Set DataWS = Sheet2 'for example
Set DestWS = Sheet3 'for example
'get the source data (at least the part with the key columns) in an array
data = DataWS.Range("A1:E" & DataWS.Cells(DataWS.Rows.Count, "B").End(xlUp).Row).Value
Set dict = CreateObject("scripting.dictionary")
'fill the dictionary - keys are combined 5 columns, values are collection
' containing the row number for each source row with that key
For r = 2 To UBound(data, 1)
k = RowKey(data, r, Array(1, 2, 3, 4, 5)) 'combination of the 5 columns
If Not dict.exists(k) Then
dict.Add k, New Collection 'new combination?
End If
dict(k).Add r
Next r
numCopied = 0
combo = 0
destRow = 2
'loop over the various key column combinations and pick a row from each
' keep looping until we've copied enough rows
Do While numCopied < COPY_ROWS
'see here for why the extra ()
'https://stackoverflow.com/questions/26585884/runtime-error-with-dictionary-when-using-late-binding-but-not-early-binding
Set col = dict.Items()(combo) 'a collection of all rows for this particular key
theRow = RemoveRandom(col)
'edit line below to copy more columns (eg change 5 to 10)
DataWS.Cells(theRow, 1).Resize(1, 5).Copy DestWS.Cells(destRow, 1)
destRow = destRow + 1 'next destination row
If col.Count = 0 Then dict.Remove dict.keys()(combo) 'remove if no more rows for this key
If dict.Count = 0 Then Exit Do 'run out of any rows to pick? (should not happen...)
combo = combo + 1
If combo >= dict.Count Then combo = 0 'start looping again
numCopied = numCopied + 1
Loop
End Sub
'Create a composite key from columns in arrKeyCols
Function RowKey(data, rowNum, arrKeyCols) As String
Dim rv, i, sep
For i = LBound(arrKeyCols) To UBound(arrKeyCols)
rv = rv & sep & data(rowNum, arrKeyCols(i))
sep = "~~"
Next i
RowKey = rv
End Function
'select a random item from a collection, remove it, and return the value
Function RemoveRandom(col As Collection)
Dim rv, num As Long
num = Application.RandBetween(1, col.Count)
RemoveRandom = col(num)
col.Remove num
End Function
Looking for a little more help please. I was here a month ago a RiskyPenguin gave me a great bit of code. I would like to add to this.
This is the part that works:
So if the "invoice" spreadsheet (sheet 5), if cell G4 (for example is I111) matches any of the data in the first column of the "income" spreadsheet (sheet 1) (starting at row 6) then the corresponding data in columns 2 3, 8 & 9 will copy over to the "invoice" spreadsheet in columns 2, 3, 4 & 5 (starting at row 13).
Sub FindAndCopyData2()
Dim shData As Worksheet, shReport As Worksheet
Set shData = Sheet1
Set shReport = Sheet6
Dim strInvoceNumber As String
strInvoceNumber = shReport.Cells(4, "E").Value
Dim intLastRow As Integer
intLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row
Dim intReportRow As Integer
intReportRow = 13
shReport.Range("B13:E20").ClearContents
Dim i As Integer
For i = 1 To intLastRow
If shData.Cells(i, 1).Value2 = strInvoceNumber Then
shReport.Cells(intReportRow, 2).Value2 = shData.Cells(i, 3).Value2
shReport.Cells(intReportRow, 3).Value2 = shData.Cells(i, 4).Value2
shReport.Cells(intReportRow, 4).Value2 = shData.Cells(i, 8).Value2
shReport.Cells(intReportRow, 5).Value2 = shData.Cells(i, 9).Value2
intReportRow = intReportRow + 1
End If
Next i
End Sub
I would then like to (hopefully using the same search)
Take the "invoice" spreadsheet (sheet 5), if cell G4 (for example is I111) matches any of the data in the second column of the "expenses" spreadsheet (sheet 2) (starting at row 11) then the corresponding data in columns 3, 5, & 7 will copy over to the "invoice" spreadsheet in columns 2, 4 & 6 (starting at row 13).
Is this possible or does it have to be a separate piece of programming?
Many Thanks for any advise.
Assuming this could be useful for others I made a function out of it and refactored the initial code to handle the copy in memory. I setup your first lookup so you just need to edit the variables to get your second lookup:
Option Explicit
''''''''''''''''''''''''''''''''''''''
''Main Sub
''''''''''''''''''''''''''''''''''''''''''''''''''
Sub main()
'Set some vars
Dim sourceArr, targetArr, sourceCls, targetCls, sourceStartRw As Long, targetStartRw As Long, dict As Object, j As Long, sourceLookupCl As Long, Matchkey As Long
''''''''''''''''''''''''''''''''''''''
''Lookup 1
''''''''''''''''''''''''''''''''''''''''''''''''''
Matchkey = Sheet5.Range("G4").Value2 'lookupKey
sourceCls = Split("2,3,8,9 ", ",") 'Columns to copy from
targetCls = Split("2,3,4,5", ",") 'Columns to copy to
sourceStartRw = 6
targetStartRw = 13
sourceLookupCl = 1 'matching column
'get data in memory = array
sourceArr = Sheet1.Range("A1").CurrentRegion.Value2
'call our function
targetArr = reorder(sourceArr, sourceCls, targetCls, sourceStartRw, sourceLookupCl, Matchkey)
'dump to sheet
With Sheet5
.Range(.Cells(targetStartRw, 1), .Cells(UBound(targetArr) + targetStartRw - 1, UBound(targetArr, 2))).Value2 = targetArr
End With
''''''''''''''''''''''''''''''''''''''
''Lookup 2 => change source and target cols to your need
''''''''''''''''''''''''''''''''''''''''''''''''''
Matchkey = Sheet5.Range("G4").Value2
sourceCls = Split("2,3,8,9 ", ",")
targetCls = Split("2,3,4,5", ",")
sourceStartRw = 6
targetStartRw = 13 'must be the same as previous lookup if you want to keep the targetArr from previous lookups
sourceLookupCl = 1
'get data in memory = array
sourceArr = Sheet1.Range("A1").CurrentRegion.Value2
'call our function keeping the data from the first lookup
targetArr = reorder(sourceArr, sourceCls, targetCls, sourceStartRw, sourceLookupCl, Matchkey, targetArr)
'dump to sheet
With Sheet5
.Range(.Cells(targetStartRw, 1), .Cells(UBound(targetArr) + targetStartRw - 1, UBound(targetArr, 2))).Value2 = targetArr
End With
End Sub
''''''''''''''''''''''''''''''''''''''
''Supporting function
''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function reorder(sourceArr, sourceCls, targetCls, sourceStartRw As Long, sourceLookupCl As Long, Matchkey As Long, Optional targetArr) As Variant
Dim dict As Object, j As Long
'if the target array overlaps the previous lookups pass it to the function
If IsMissing(targetArr) Then
ReDim targetArr(1 To UBound(sourceArr), 1 To UBound(sourceArr, 2))
End If
'build a dict to compare quickly
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
For j = 1 To UBound(sourceArr) 'traverse source
dict(sourceArr(j, sourceLookupCl)) = Empty
Next j
'check if key exists in dict and copy data
Dim i As Long, ii As Long ': ii = 1
If dict.Exists(Matchkey) Then
For j = sourceStartRw To UBound(sourceArr)
For i = 1 To UBound(sourceArr, 2)
If i = sourceCls(ii) Then
targetArr(j - sourceStartRw + 1, targetCls(ii)) = sourceArr(j, i)
ii = IIf(ii < UBound(sourceCls), ii + 1, ii)
End If
Next i
ii = 0
Next j
End If
reorder = targetArr
End Function
Hi I have 2 columns (cities and members) with 5 unique cities and 100,000 members. Some members may be assigned to multiple cities. I would like a graph that has 6 columns and the 6 rows of the cities (with additional No City Assigned Column). The values in the table would be the member counts. So I'm basically trying to count overlap. How can I accomplish this?
I wish it would be as simple as dragging my cities field into both columns and rows in the pivot table but I can't.
I would like it to look like this:
Assuming you want conditional formatting:
Select the full range you want to apply the formatting to. Then apply a rule (formula option) so that =B$1=$A2 (assuming your have selected from B2 to some end). The use of the fixed ("$") condition on column or row helps determine that this applies to each cell in the selected range individually.
Here's a VBA solution. Set up a working array with one row for each distinct member, one column for each distinct city, and fill with 1's where member and city coincide. Then transfer into output array where pairs of columns in working array have been set to 1:
Option Explicit
Sub MultResponse()
Dim LastRow, LastColumn As Long
Dim sht1, sht2 As Worksheet
Dim workArray() As Integer
Dim cityDict As New Scripting.Dictionary
Dim memberDict As New Scripting.Dictionary
Dim city, member As String
Dim item As Integer
Dim i, j As Long
Dim memberNo As Long
Dim cityNo As Integer
Dim outputArray() As Integer
Dim outrow, outcol, rowTotal As Integer
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
' Make list of distinct cities
j = 0
For i = 2 To LastRow
city = sht1.Cells(i, 2)
If city <> "" And Not cityDict.Exists(city) Then
j = j + 1
cityDict.Add Key:=city, item:=j
End If
Next i
' Make list of distinct members
j = 0
For i = 2 To LastRow
member = sht1.Cells(i, 1)
If member <> "" And Not memberDict.Exists(member) Then
j = j + 1
memberDict.Add Key:=member, item:=j
End If
Next i
' Set up and fill array with one row for each distinct member, one column for each distinct city
ReDim workArray(1 To memberDict.Count, 0 To cityDict.Count)
For i = 2 To LastRow
member = sht1.Cells(i, 1)
city = sht1.Cells(i, 2)
If city <> "" And member <> "" Then
memberNo = memberDict(member)
cityNo = cityDict(city)
workArray(memberNo, cityNo) = 1
End If
Next i
' Fill output array where pairs of columns in work array are set to 1
' outputArray(0,0) is used for members with missing city
ReDim outputArray(0 To cityDict.Count, 0 To cityDict.Count)
'First do ones with no affiliation
For i = 1 To memberDict.Count
rowTotal = 0
For j = 1 To cityDict.Count
rowTotal = rowTotal + workArray(i, j)
Next j
If rowTotal = 0 Then outputArray(0, 0) = outputArray(0, 0) + 1
Next i
' Then do ones with affiliation
For outrow = 1 To cityDict.Count
For outcol = 1 To cityDict.Count
For i = 1 To memberDict.Count
If workArray(i, outrow) = 1 And workArray(i, outcol) = 1 _
Then outputArray(outrow, outcol) = outputArray(outrow, outcol) + 1
Next i
Next outcol
Next outrow
' Transfer output array into sheet
For i = 0 To cityDict.Count
For j = 0 To cityDict.Count
sht2.Cells(i + 2, j + 2) = outputArray(i, j)
Next j
Next i
'Insert row and column headers
sht2.Cells(1, 2) = "N/C"
sht2.Cells(2, 1) = "N/C"
For i = 0 To cityDict.Count - 1
sht2.Cells(i + 3, 1) = cityDict.Keys(i)
Next i
For j = 0 To cityDict.Count - 1
sht2.Cells(1, j + 3) = cityDict.Keys(j)
Next j
End Sub
Test data
Results
I need to assigned a value on Column B depending on the condition in Column A. I formulate a simple code using IF...ElseIf condition (see code below). I have 1000 conditions and I am thinking if I can use a 2 separate arrays for the value of Column A and get the index of the value in column A to 1st array (Array1 ) and match it to the 2nd array (AssignedArray). Something like, for each value found in Column A check the Array1 if the value is exist and get the index and match the index to AssignedArray. Like for example,
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
CODE
For x = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For Each wrd In Sheets(1).Cells(x, 1)
val = wrd
If UCase(val) = "DL2005" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "EFRUEN" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "DESTDIDIER" Then
Sheets(1).Cells(x, 3).Value = "Operations"
ElseIf UCase(val) = "EOGRADY3" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "EKARLSON1" Then
Sheets(1).Cells(x, 3).Value = "Analyst"
ElseIf UCase(val) = "EOKUTOMI1" Then
Sheets(1).Cells(x, 3).Value = "Operations"
End If
Next wrd
Next x
Is it possible to do that?Or is there any way on how to simplify my code instead of using IF ELSEIF condition.
If you have 1k conditions (as you do), then I imagine neither If nor Select statements are appropriate. Furthermore, creating/maintaining expressions (in your code) that evaluate to two 1k-element arrays may be burdensome.
A maintenance friendly approach might be to keep the items in Array1 on some worksheet, and keep the contents of AssignedArray right next to it. Something like the below. Say the yellow values are items that you would have put into Array1 and green values are items you would have put into AssignedArray (I only have 25 as an example).
Then you wouldn't necessarily need any VBA and could purely use Excel functions like VLOOKUP -- or MATCH and INDEX in conjunction. For example, I put this formula in cell E4, which tries to find the value in D4 among the values in column A and returns the corresponding value from column B:
=INDEX($B$1:$B$25,MATCH(D4,$A$1:$A$25,0))
If you still wanted to use VBA, this code should loop over cells D4:D8 (which is the correct range for my spreadsheet, but probably not for yours), make them uppercase (in memory only, not on the sheet), then write the corresponding values in G4:G8:
Option Explicit
Private Sub FillInAssociatedValuesValue()
Dim inputKeys() As Variant ' <-- AKA Array1
inputKeys = ThisWorkbook.Worksheets("Sheet1").Range("A1:A25").Value2 ' Change to wherever items from Array1 are kept
Dim inputValues() As Variant '<-- AKA AssignedArray
inputValues = ThisWorkbook.Worksheets("Sheet1").Range("B1:B25").Value2 ' Change to wherever items from AssignedArray are kept
If (UBound(inputKeys, 1) - LBound(inputKeys, 1)) <> (UBound(inputValues, 1) - LBound(inputValues, 1)) Then
MsgBox ("The number of keys should be the same as the number of associated values. Code will stop running now.")
Exit Sub
End If
Dim dict As Object 'Shouldn't need to add a reference
Set dict = CreateObject("Scripting.Dictionary")
' One pass to fill the dictionary. If there are duplicates, will only add first instance.
Dim rowIndex As Long
For rowIndex = LBound(inputKeys, 1) To UBound(inputKeys, 1)
If Not dict.Exists(inputKeys(rowIndex, 1)) Then
dict.Add UCase$(inputKeys(rowIndex, 1)), inputValues(rowIndex, 1)
End If
Next rowIndex
Dim Key As String
With ThisWorkbook.Worksheets("Sheet1")
For rowIndex = 4 To 8 ' I needed to loop over range D4:D8
Key = UCase$(.Cells(rowIndex, "D").Value2)
If dict.Exists(Key) Then
.Cells(rowIndex, "G").Value2 = dict.Item(Key)
Else
' Some logic in case input is not found, and cannot be mapped to some associated value
.Cells(rowIndex, "G").Value2 = "VALUE NOT FOUND"
End If
Next rowIndex
End With
End Sub
To keep it simple; use For loops to compare Array1 to each cell in column A and if there is a match, use Offset put the corresponding element from AssignedArray into the cell on the right.
Dim Array1 As Variant, AssignedArray As Variant
Dim x As Long, i As Long
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
For x = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = LBound(Array1) To UBound(Array1)
If Cells(x, 1).Value = Array1(i) Then
Cells(x, 1).Offset(, 1).Value = AssignedArray(i)
End If
Next i
Next x
Try
Sub test()
Dim Ws As Worksheet
Dim Array1, AssignedArray
Dim s As String, i As Integer, r As Long, x As Long
Dim k As Integer
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
Set Ws = Sheets(1)
r = Ws.Cells(Rows.Count, 1).End(xlUp).Row
With Ws
For x = 1 To r
s = UCase(.Cells(x, 1))
For i = LBound(Array1) To UBound(Array1)
If s = Array1(i) Then
k = i
Exit For
End If
Next i
.Cells(x, 3) = AssignedArray(k)
Next x
End With
End Sub
If you have a lot of data, it is better to speed up the results by arranging the results into a single sheet instead of entering them one by one into the cell.
Sub test2()
Dim Ws As Worksheet
Dim Array1, AssignedArray
Dim s As String, i As Integer, r As Long, x As Long
Dim k As Integer
Dim vDB, vR()
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
Set Ws = Sheets(1)
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 1)
For x = 1 To r
s = UCase(vDB(x, 1))
For i = LBound(Array1) To UBound(Array1)
If s = Array1(i) Then
k = i
Exit For
End If
Next i
vR(x, 1) = AssignedArray(k)
Next x
.Range("c1").Resize(r) = vR
End With
End Sub