I want to get 1st,2nd,3rd,...nth...small values in dates which are on column D. but there was a specific category which is shown in column E. I wrote a code to get a specific range call p. and it is working. that means when category C it selects only C values in the range. when it is equal F it gets only F values.
Now I want to get a row number of 1st small value. but category C it gives correct small value. but it becomes category F it again gave the previous results. can anyone help me with this problem.?
dim p as range, c as range, i as integer, irow as long
dim ary(1 to 5) as varient
ary(1) = "C"
ary(2) = "F"
ary(3) = "B"
ary(4) = "PC"
ary(5) = "BC"
For i = 1 To UBound(ary)
cat = ary(i)
Set p = Nothing
Set c = Nothing
For Each c In Range("E: E")
If c.Value = cat Then
If p Is Nothing Then
Set p = c.Offset()
Else
Set p = Union(p, c)
End If
End If
Next c
irow = Application.WorksheetFunction.Match(WorksheetFunction.Small(p.Offset(, -1), 1), Range("D:D"), 0)
Cells(4, 12) = Cells(irow, 5)
next i
Related
I'm extremely new to VBA and have tried Googling to find what I need, but have fallen short.
I have a sheet (Sheet1) containing a list of companies that currently have, or at some point have had, a subscription. The list contains the City (Col A), the Company (Col B), the Category (Col C) and a Cancellation Date (Col D) (if applicable). What I want to do is fill in the current company for that city/category on a different sheet. I want those headers to be City (Col D), Category 1 (Col E), Category 2 (Col F), and Category 3 (Col G).
Here are images of the two sheets of test data:
Sheet 1
Sheet 2
There can only be one company per category per city. For example: in my test data, company D was under Category 1 in San Antonio, but cancelled on 11/12/2021. Then, company N took that spot in San Antonio. So, in my table on Sheet 2, I want company N to be populated. The data set I'm using this for is very large and constantly changing, so I would like an automated way to do this.
Here is a copy of the code I pieced together:
Sub CompanyLookup()
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Dim lastRowInCity, lastRowOutCity, i, k, m As Long
Dim lookFor, j, inArray, outArray, findArray As Variant
Dim inWks, outWks As Worksheet
Set inWks = ThisWorkbook.Sheets(1)
Set outWks = ThisWorkbook.Sheets(2)
lastRowInCity = inWks.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutCity = outWks.Cells(Rows.Count, "D").End(xlUp).Row
lastRowCategory = inWks.Cells(Rows.Count, "C").End(xlUp).Row
lastRowDate = inWks.Cells(Rows.Count, "D").End(xlUp).Row
lastColCategory = outWks.Cells(Columns.Count, "D").End(xlToLeft).Column
inArray = Range(inWks.Cells(1, 1), inWks.Cells(lastRowInCity, 3))
findArray = Range(outWks.Cells(1, 4), outWks.Cells(lastRowOutCity, 4))
outArray = Range(outWks.Cells(1, 5), outWks.Cells(lastRowOutCity, 5))
On Error Resume Next
For i = 2 To lastRowOutCity
For j = 2 To lastRowInCity
For k = 2 To lastRowCategory
For m = 2 To lastRowDate
lookFor = findArray(i, 1)
If inArray(j, 1) = lookFor And inArray(m, 4) < 1 And inArray(k, 3) = outArray(lastColCategory, 1) Then
outArray(i, 1) = inArray(j, 2)
Exit For
End If
Next j
Next m
Next k
Next i
Range(outWks.Cells(1, 5), outWks.Cells(lastRowOutCity, 5)) = outArray
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Assuming your data looks exactly as your screenshots:
Sub CompanyLookup()
Dim sourceData, resultData, rngSource As Range, rngResult As Range
Dim r As Long, c As Long, city As String, cat As String, rSrc As Long
Set rngSource = ThisWorkbook.Sheets(1).Range("A1").CurrentRegion
Set rngResult = ThisWorkbook.Sheets(2).Range("D1").CurrentRegion
sourceData = rngSource.Value
resultData = rngResult.Value
'scan through the results array
For r = 2 To UBound(resultData, 1)
city = resultData(r, 1) 'city
For c = 2 To UBound(resultData, 2)
cat = resultData(1, c) 'category
'Scan the source data for a city+category match,
' ignoring lines with a cancellation date
For rSrc = 2 To UBound(sourceData, 1)
If Len(sourceData(rSrc, 4)) = 0 Then 'no cancellation date
If sourceData(rSrc, 1) = city And sourceData(rSrc, 3) = cat Then
resultData(r, c) = sourceData(rSrc, 2) 'populate the company
Exit For 'done searching
End If
End If
Next rSrc
Next c
Next r
rngResult.Value = resultData 'populate the results
End Sub
I had exact same issue this week, and from what i read online, the fact that you cannot use vlookup or find function for multiple criteria. Mostly people prefer using .find fuction and when you find it, you can use loop to find second criteria. It was what i used.
I have a spreadsheet that lists all permutations of 5 columns of data into a single column of text (Column X aka 24) and my goal is to extract only actual words from that list into its own column (Column Y aka 25). The first part is not performed with VBA and happens almost instantaneously, but the spell check + extracting the actual words takes over an hour to complete (I've had to stop it it after 10 minutes and not even 10% of the way through). Is there a better way to do this?
My lists start on row 6 (n = 6) and Range("V3") is just the number of permutations (in this case, 83,521).
Sub Permute_and_Extract()
n = 6
Range("X7:X1000000").ClearContents
Range("Y6:Y1000000").ClearContents
Max = Range("V3") + 5
Range("X6").Select
Selection.AutoFill Destination:=Range("X6:X" & Max)
For i = 6 To Max
x = Application.CheckSpelling(Cells(i, 24).Text)
If x = True Then
Cells(n, 25) = Cells(i, 24)
n = n + 1
End If
Next i
End Sub
Following from the comments above:
Sub Permute_and_Extract()
Const RNG As String = "F1:F10000"
Dim wlist As Object, t, c As Range, i As Long, arr, res
Dim rngTest As Range
Set rngTest = ActiveSheet.Range(RNG)
t = Timer
Set wlist = WordsList("C:\Temp\words.txt", 5)
Debug.Print "loaded list", Timer - t
Debug.Print wlist.Count, "words"
'using an array approach...
t = Timer
arr = rngTest.Value
For i = 1 To UBound(arr, 1)
res = wlist.exists(arr(i, 1))
Next i
Debug.Print "Array check", Timer - t
'going cell-by-cell...
t = Timer
For Each c In rngTest.Cells
res = wlist.exists(c.Value)
Next c
Debug.Print "Cell by cell", Timer - t
End Sub
'return a dictionary of words of length `wordLen` from file at `fPath`
Function WordsList(fPath As String, wordLen As Long) As Object
Dim dict As Object, s As String
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare 'case-insensitive !!!
With CreateObject("scripting.filesystemobject").opentextfile(fPath)
Do While Not .AtEndOfStream
s = .readline()
If Len(s) = wordLen Then dict.Add s, True
Loop
.Close
End With
Set WordsList = dict
End Function
Output:
loaded list 0.359375
8938 words
Array check 0.019
Cell by cell 0.030
I have an Excel sheet with two sets of cells that require user input. The first set has 8 inputs, the second set has 5.
Let's say the Data Sets One and Two have user inputs of letters, like so:
DataSetOne(0) = A
DataSetOne(1) = B
DataSetOne(2) = C
DataSetOne(3) = D
DataSetOne(4) = E
DataSetOne(5) = F
DataSetOne(6) = G
DataSetOne(7) = H
DataSetTwo(0) = A
DataSetTwo(1) = B
DataSetTwo(2) = H
DataSetTwo(3) = D
DataSetTwo(4) = C
I need to check for replicated data. I only care if any two consecutive values are repeated, not just single values.
For example, Data Set One contains seven sequential "pairs" of input data:
Pair 1 = A, B
Pair 2 = B, C
Pair 3 = C, D
Pair 4 = D, E
Pair 5 = E, F
Pair 6 = F, G
Pair 7 = G, H
And similarly, Data Set Two has four additional pairs of data:
Pair 8 = A, B
Pair 9 = B, H
Pair 10 = H, D
Pair 12 = D, C
I need to see if any of these pairs match. Order does not matter - as long as two pairs have the same two individual inputs, I need to make a decision one way. If the pairs do not contain both matching values, then my decision goes a different way.
So in the above example, there are matches between:
Pair 1 and Pair 8
Pair 3 and Pair 12
To find the duplicates, i.e. values present in both of the lists, the easiest way to implement is to simply do a brute force search iterating over both lists. Depending on your application, this may be good enough.
For example:
Public Sub SO70184805_find_duplicates()
Dim DataSetOne(0 To 7) As String
Dim DataSetTwo(0 To 4) As String
Const Delimiter As String = ", "
DataSetOne(0) = "A"
DataSetOne(1) = "B"
DataSetOne(2) = "C"
DataSetOne(3) = "D"
DataSetOne(4) = "E"
DataSetOne(5) = "F"
DataSetOne(6) = "G"
DataSetOne(7) = "H"
DataSetTwo(0) = "A"
DataSetTwo(1) = "B"
DataSetTwo(2) = "H"
DataSetTwo(3) = "D"
DataSetTwo(4) = "C"
Dim PairsOne(0 To 6) As String
Dim PairsTwo(0 To 3) As String
Dim I As Integer
Dim S1 As Variant
Dim S2 As Variant
'Make the lists of pairs
Debug.Print "Pairs from the first list:"
For I = 0 To 6
If (DataSetOne(I) < DataSetOne(I + 1)) Then
PairsOne(I) = DataSetOne(I) & Delimiter & DataSetOne(I + 1)
Else
PairsOne(I) = DataSetOne(I + 1) & Delimiter & DataSetOne(I)
End If
Debug.Print (PairsOne(I))
Next I
Debug.Print
Debug.Print "Pairs from the second list:"
For I = 0 To 3
If (DataSetTwo(I) < DataSetTwo(I + 1)) Then
PairsTwo(I) = DataSetTwo(I) & Delimiter & DataSetTwo(I + 1)
Else
PairsTwo(I) = DataSetTwo(I + 1) & Delimiter & DataSetTwo(I)
End If
Debug.Print (PairsTwo(I))
Next I
Debug.Print
Debug.Print ("Duplicates:"):
Dim NumberOfDuplicates As Integer
NumberOfDuplicates = 0
For Each S1 In PairsOne
For Each S2 In PairsTwo
If (S1 = S2) Then
Debug.Print (S1)
NumberOfDuplicates = NumberOfDuplicates + 1
End If
Next
Next
End Sub
This is the output:
Pairs from the first list:
A, B
B, C
C, D
D, E
E, F
F, G
G, H
Pairs from the second list:
A, B
B, H
D, H
C, D
Duplicates:
A, B
C, D
Something along these lines, i'm heading off home now so can't do much more. I'll revisit later if possible. You'll need to add the scripting runtime reference to use the dictionary.
Sub datasets()
Dim datasetone(7) As String
Dim datasettwo(4) As String
Dim dicPairsOne As New Scripting.Dictionary
Dim dicPairsTwo As New Scripting.Dictionary
Dim l As Long
Dim strPair As String
datasetone(0) = "A"
datasetone(1) = "B"
datasetone(2) = "C"
datasetone(3) = "D"
datasetone(4) = "E"
datasetone(5) = "F"
datasetone(6) = "G"
datasetone(7) = "H"
datasettwo(0) = "A"
datasettwo(1) = "B"
datasettwo(2) = "H"
datasettwo(3) = "D"
datasettwo(4) = "C"
For l = 0 To UBound(datasetone) - 1
strPair = datasetone(l) & "," & datasetone(l + 1)
If Not dicPairsOne.Exists(strPair) Then
dicPairsOne.Add strPair, 1
Else
dicPairsOne(strPair) = dicPairsOne(strPair) + 1
End If
If Not dicPairsOne.Exists(StrReverse(strPair)) Then
dicPairsOne.Add StrReverse(strPair), 1
Else
dicPairsOne(StrReverse(strPair)) = dicPairsOne(StrReverse(strPair)) + 1
End If
Next l
For l = 0 To UBound(datasettwo) - 1
strPair = datasettwo(l) & "," & datasettwo(l + 1)
If Not dicPairsTwo.Exists(strPair) Then
dicPairsTwo.Add strPair, 1
Else
dicPairsTwo(strPair) = dicPairsTwo(strPair) + 1
End If
Next l
For l = 0 To dicPairsOne.Count - 1
If dicPairsTwo.Exists(dicPairsOne.Keys()(l)) Then
Debug.Print dicPairsOne.Keys()(l)
End If
Next l
End Sub
I have two columns, the first one is a date with Year/Month format and the other a numerical value of an evaluation that i have done. I want to get the average value for each month with a macro( i need to do it so many times an a lot of data on it). So, i decided to create an array of dates and a Matrix of evaluation results. The goal is to group all numeric values by date and get the average per month. The problem is that this code ignores the value when the actual and last cells are different.
Dim i As Integer 'number of rows
Dim J As Integer 'manage row change
Dim G As Integer 'manage column change
Dim Fecha(48) As String
Dim Matriz_FI(100, 100) As Double
'-------------------------------------------------------------- --
J = 0
G = 0
For i = 2 To 10
If i = 2 Then
Matriz_FI(J, G) = Sheets("Nueva Database").Cells(i, 11).Value
Fecha(J) = Sheets("Nueva Database").Cells(i, 3).Value
G = G + 1
Else
If (Sheets("Nueva Database").Cells(i, 3).Value = Sheets("NuevaDatabase").Cells(i - 1, 3).Value) Then
'Column change in Matriz_FI
Matriz_FI(J, G) = Sheets("Nueva Database").Cells(i, 11).Value
G = G + 1
MsgBox ("Same")
Else
'Row change in Matriz_FI
J = J + 1
Fecha(J) = Sheets("Nueva Database").Cells(i, 3)
G = 0
Matriz_FI(J, G) = Sheets("Nueva Database").Cells(i, 11).Value
MsgBox ("Different")
End If
End If
Next
End Sub
I have an excel set for which I need to count entries based on names. They're all in the same column and there is supposed to be 4 of each entry. I need a formula to count the number of cells with the same entry that do NOT start with either "Retail" or "Commercial" and only return the names in the cells for which there is NOT 4. For example, if my data looks thusly:
NAME
Retail - John
Retail - Sue
Kara
Kara
Joe
Joe
Joe
Joe
Commercial
Sarah
I want a formula that will search this column, and only return "Kara - 2" and "Sarah - 1". The "Retail" and "Commercial" are excluded from the start and since "Joe"=4 I'm not concerned with that. Is there some way I can have this search the column, have it return the first count to meet that criteria to C1, the next one to C2 and so on until I have a column of just the non-compliant entries? I'd love an output like below:
NAME COUNT
Kara 2
Sarah 1
Thanks for looking, I really appreciate any help and advice you can offer!
If your data is in column A the results table will be in columns B & C after running this macro:
Sub MAIN()
Dim A As Range, wf As WorksheetFunction
Dim s1 As String, s2 As String
Dim col As Collection
Set A = Intersect(Range("A:A"), ActiveSheet.UsedRange)
Set wf = Application.WorksheetFunction
Set col = MakeColl(A)
s1 = "Retail"
s2 = "Commercial"
K = 1
For i = 1 To col.Count
v = col.Item(i)
If InStr(v, s1) = 0 And InStr(v, s2) = 0 Then
n = wf.CountIf(A, v)
If n <> 4 Then
Cells(K, "B").Value = v
Cells(K, "C").Value = n
K = K + 1
End If
End If
Next i
End Sub
Public Function MakeColl(rng As Range) As Collection
Set MakeColl = New Collection
Dim r As Range
On Error Resume Next
For Each r In rng
v = r.Value
If v <> "" Then
MakeColl.Add v, CStr(v)
End If
Next r
MsgBox MakeColl.Count
End Function