This is an extension of this question. I want to do something similar, but I am not very familiar with dictionary objects, and the code provided in the answer is very advanced, so I am having trouble understanding it. For instance, some of the syntax is not very clear, and variable names are not very obvious/intuitive. I am creating a new question because the original problem has been solved.
I want to do exactly the same thing as in the linked question, but instead of counting cell values in column H, I want to count AOI entries (and ignore exits) per trial and block in column I, and print the number in column U.
If you could also provide an explanation of the solution to accompany your solution (so that I understand what is going on), that would be appreciated. Or at least explain what is going on in the previous solution.
Here is a link to my most up to date sample data and code.
I've figured it out. Here is the code:
Dim dBT As Object 'global dictionary
Sub buttonpresscount()
'constants for column positions
Const COL_BLOCK As Long = 1
Const COL_TRIAL As Long = 2
Const COL_ACT As Long = 7
Const COL_AOI As Long = 8
Dim rng As Range, lastrow As Long, sht As Worksheet
Dim d, r As Long, k, resBT()
Set sht = Worksheets("full test")
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
Set dBT = CreateObject("scripting.dictionary")
Set rng = sht.Range("B7:I" & lastrow)
d = rng.Value 'get the data into an array
ReDim resBT(1 To UBound(d), 1 To 1) 'resize the array which will
' be placed in ColT
'get unique combinations of Block and Trial and pressedcounts for each
For r = 1 To UBound(d, 1)
k = d(r, COL_BLOCK) & "|" & d(r, COL_TRIAL) 'create key
dBT(k) = dBT(k) + IIf(d(r, COL_ACT) <> "", 1, 0)
Next r
'populate array with appropriate counts for each row
For r = 1 To UBound(d, 1)
k = d(r, 1) & "|" & d(r, 2) 'create key
resBT(r, 1) = dBT(k) 'get the count
Next r
'place array to sheet
sht.Range("T7").Resize(UBound(resBT, 1), 1) = resBT
'clear dictionary
dBT.RemoveAll
'count AOI entries
For r = 1 To UBound(d, 1)
k = d(r, COL_BLOCK) & "|" & d(r, COL_TRIAL) 'create key
dBT(k) = dBT(k) + IIf(d(r, COL_AOI) = "AOI Entry", 1, 0)
Next r
'populate array with appropriate counts for each row
For r = 1 To UBound(d, 1)
k = d(r, 1) & "|" & d(r, 2) 'create key
resBT(r, 1) = dBT(k) 'get the count
Next r
'place array to sheet
sht.Range("U7").Resize(UBound(resBT, 1), 1) = resBT
End Sub
I basically duplicated the previous code, added another constant for the relevant column and changed the relevant references to columns, and made sure to clear the dictionary inbetween counting tasks.
Related
I have a code that matches a cell value in Column C on Sheet1 to a pivot table on Sheet3 and then copies certain columns over.
Code will check how many entries there are on Sheet1 that need to be checked
Loop 2: For every value in Column C/Sheet1 with a match in Column A on Sheet 2 it will then copy over the corresponding data from Column B,C,D,E.
Since there are multiple matches possible by value/Sheet I am limiting the data pull to three matches (three loops in the code). To achieve that I am increasing i +1 or i+2 to get the next row in the pivot table.
The table on Sheet 2 is sometimes 10,000+ rows and excel crashes.
Does anyone have an idea how to speed up the loop codes (Loop2,3,4 are the same) to make it less work intensive e.g. array possibly? They are causing the lock up since I think the code keeps running up and down column A.
Set sheet3 = Sheets("OrbitPivotTable")
CellChanged = Sheet1.Range("A1").Value + 1
LastRow = sheet3.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
'Loop1
For i = 1 To LastRow
If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep2
If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
Sheet1.Range("H" & CellChanged).Value = sheet3.Range("B" & i).Value 'Customer
Sheet1.Range("I" & CellChanged).Value = sheet3.Range("C" & i).Value 'Rate Val start
Sheet1.Range("J" & CellChanged).Value = sheet3.Range("D" & i).Value 'ATA All in
Sheet1.Range("K" & CellChanged).Value = sheet3.Range("E" & i).Value 'Special Remarks
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep2:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
'Loop2
etc....
Excel File
I might have misunderstood the process in the file you shared, but this should be faster (and much less code overall).
I put the pivot table lookup in a loop, switched to Match(), and reduced the number of read/writes using arrays where possible.
EDITED to fix an embarrassing bug where I forgot to adjust the Match() result m to account for the starting row of the range I run match() against...
Sub HB_IPT_Rate_Check()
Dim wsReport As Worksheet, wsCPK As Worksheet, wsOrbitPivot As Worksheet
Dim c As Range, rwReport As Range, lastPivotRow As Long
Dim ata, m, numMatches As Long, matchFrom As Long, matchRow As Long
Set wsReport = ThisWorkbook.Worksheets("Comparison Report")
Set wsCPK = ThisWorkbook.Worksheets("CPK")
Set wsOrbitPivot = ThisWorkbook.Worksheets("OrbitPivotTable")
'loop over the rows in the report sheet
For Each c In wsReport.Range("C3", wsReport.Cells(Rows.Count, "C").End(xlUp)).Cells
ata = c.Value 'read this once....
Set rwReport = c.EntireRow
'1st Database Match "CPK"
m = Application.Match(ata, wsCPK.Columns("A"), 0)
If Not IsError(m) Then
With wsCPK.Rows(m)
rwReport.Columns("D").Resize(1, 4).Value = _
Array(.Columns("B").Value, .Columns("C").Value, _
.Columns("F").Value, .Columns("H").Value)
'Sum of HB CWGT (KG),Sum of MB CWGT (KG),Achiev CPK,Density
End With
Else
'no match...
End If
'2nd Database Match "Orbit"
lastPivotRow = wsOrbitPivot.Cells(Rows.Count, "A").End(xlUp).Row
numMatches = 0 'reset match count
matchFrom = 2
m = Application.Match(ata, wsOrbitPivot.Range("A" & matchFrom & ":A" & lastPivotRow), 0)
'keep going while we still have a match and we've not reached the max result count
Do While Not IsError(m) And numMatches < 3
numMatches = numMatches + 1
matchRow = matchFrom + (m - 1) 'adjust the matched row index according to where we started looking...
'sanity check
Debug.Print "Matched " & ata & " on row " & matchRow
rwReport.Columns("H").Offset(0, (numMatches - 1) * 4).Resize(1, 4).Value = _
wsOrbitPivot.Cells(matchRow, "B").Resize(1, 4).Value
'find the next match if any, starting below the last match
matchFrom = matchRow + 1
m = Application.Match(ata, wsOrbitPivot.Range("A" & matchFrom & ":A" & lastPivotRow), 0)
Loop
Next c 'next report row
End Sub
Use Dictionary to set row and column number.
Data is assigned to fit rows and columns in a virtual array.
Sub test()
Dim Ws(1 To 4) As Worksheet
Dim DicR As Object ' Dictionary
Dim DicC As Object ' Dictionary
Dim vDB, arr()
Dim s As String
Dim i As Long, n As Long, j As Integer
Dim r As Long, c As Integer
Set Ws(1) = Sheets("Comparison Report")
Set Ws(2) = Sheets("CPK")
Set Ws(3) = Sheets("OrbitPivotTable")
Set Ws(4) = Sheets("Orbit")
'Row index dictionary
Set DicR = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
'Column index dictionary
Set DicC = CreateObject("Scripting.Dictionary") ' New Scripting.Dictionary
vDB = Ws(1).UsedRange
For i = 3 To UBound(vDB, 1)
s = vDB(i, 3)
If s <> "" Then
If DicR.Exists(s) Then
'DicC(s) = DicC(s) + 1
Else
n = n + 1
DicR.Add s, n 'row index
DicC.Add s, 0 'column index
End If
End If
Next i
'Create an array of virtual tables based on the number of dictionaries.
'Since the number of columns cannot be predicted, a specific number of 1000 was entered.
'in my test, number 100 is too small
ReDim arr(1 To DicR.Count, 1 To 1000)
For j = 2 To 4
vDB = Ws(j).Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
s = vDB(i, 1)
If DicR.Exists(s) Then
r = DicR(s)
c = DicC(s) * 4 + 1
DicC(s) = DicC(s) + 1
arr(r, c) = vDB(i, 2)
arr(r, c + 1) = vDB(i, 3)
arr(r, c + 2) = vDB(i, 4)
arr(r, c + 3) = vDB(i, 5)
End If
Next i
Next j
With Ws(1)
.Range("d3").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Result image
I’m in a situation where I need to reproduce something in VBA and a bit stuck given my lack of understanding of object oriented language and VBA in general.
Problem:
I need to produce an array or vector based on a 2 column table.
The first range (column) contains unit counts.
The second range (column) contains numeric values.
I need to replicate the value based on the number of units.
For example,
if the first row contains 3 units with a value of $100
I need the array to contain $100, $100, $100.
This will need to be looped thru each row containing units.
So if row 2 contains 2 units with a value of $50
I need to complete array to be $100, $100, $100, $50, $50, and so on.
I understand this situation will require ReDim the array based on the total values. My struggle is I’ve been unable to figure out the nested for loops.
I get how to replicate the value based on the number of “units” like the below...
ReDim arr(0 To x - 1)
For i = 0 To x - 1
arr(i) = rng.Offset(0, 1).Value
Next
What is the best way to loop thru each row and replicate the values for each row in the range based on the unit count?
If anyone is familiar with R, I'm essentially looking for something that achieves the rep() function (e.g., rep(df$b, df$a)) and return the values in a single array.
Any help is greatly appreciated. Thanks
Or a one liner which uses the REPT function as you would have used in r :)
This assumes your data is in A1:B10 - the length can be made variable
s = Split(Join(Application.Transpose(Evaluate("=INDEx(REPT(B1:B10&"","",A1:A10),,1)"))), ",")
An an example, to dump the new to array to C1
s = Split(Join(Application.Transpose(Evaluate("=INDEx(REPT(B1:B10&"","",A1:A10),,1)"))), ",")
[c1].Resize(UBound(s), 1) = Application.Transpose(s)
When you say Row contains 3 units, do you mean the cell has value 3 or 3 Units? If it is 3 then you may not have to Redim the array in the loop. Simply find the sum of values in Col A which has units and Redim it in one go as shown below.
Sub Sample()
Dim ws As Worksheet
Dim Ar() As String
Dim n As Long, i As Long, lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet6
With ws
n = Application.WorksheetFunction.Sum(.Columns(1))
ReDim Ar(t To n)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
n = 1
For i = 1 To lRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
For j = 1 To .Range("A" & i).Value
Ar(n) = .Range("B" & i).Value
n = n + 1
Next j
End If
Next i
For i = LBound(Ar) To UBound(Ar)
Debug.Print Ar(i)
Next i
End With
End Sub
Screenshot
And if the cell has 3 Units then you will have to store the values of Col A in an array, do a replace on Unit/Units, find the sum and finally use the above code. Here is an example
Sub Sample()
Dim ws As Worksheet
Dim Ar() As String, tmpAr As Variant
Dim n As Long, i As Long, j As Long, k As Long, lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet6
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
tmpAr = .Range("A1:A" & lRow).Value
For i = LBound(tmpAr) To UBound(tmpAr)
tmpAr(i, 1) = Replace(tmpAr(i, 1), "Units", "")
tmpAr(i, 1) = Trim(Replace(tmpAr(i, 1), "Unit", ""))
n = n + Val(tmpAr(i, 1))
Next i
ReDim Ar(t To n)
n = 1
For i = 1 To lRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
k = Val(Trim(Replace(Replace(.Range("A" & i).Value, "Units", ""), "Unit", "")))
For j = 1 To k
Ar(n) = .Range("B" & i).Value
n = n + 1
Next j
End If
Next i
For i = 1 To UBound(Ar)
Debug.Print Ar(i)
Next i
End With
End Sub
Screenshot
if your data is already in an array then ReDim'ing will delete it's contents. You can ReDim Preserve but it's an expensive operation, better to create a new array to put the results into.
I have assumed the data is contained within a Named Range called "Data" with Units being the first column and Values being the second column.
if your data changes regularly you can create a dynamic range using the OFFSET function i.e. =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),2) assuming your data starts in cell A1 and there is no header row.
Sub ProcessData()
Dim DataArr() As Variant
Dim QtyColArr() As Variant
Dim ResultArr() As Variant
Dim TotalQty As Long
Dim i As Long, j As Long, k As Long
'store data into array
DataArr = Range("Data") 'assume data stored in named range called "Data"
'store Qty col into 1D array
QtyColArr = Range("Data").Resize(, 1)
'sum all qty vals
TotalQty = Application.Sum(QtyColArr)
're-size ResultsArray
ReDim ResultArr(1 To TotalQty)
'Initialize ResultsArr counter
k = LBound(ResultArr)
'loop DataArr
For i = LBound(DataArr) To UBound(DataArr)
'loop qty for current row
For j = 1 To DataArr(i, 1)
'copy value
ResultArr(k) = DataArr(i, 2)
'iterate ResultsArr counter
k = k + 1
Next j
Next i
'output to intermediate window
Debug.Print "{" & Join(ResultArr) & "}"
End Sub
I have a giant dataset that looks like this
I am trying to go down the list of different companies and grab 3 per company and combine them. Based on the photo above, I would have 2 different lists with 3 companies each (except TH Repair which will have 2 in the final list).
My real dataset contains hundreds of different companies, each with dozens/hundreds of entries so I would finish with dozens of lists (each potentially hundreds long).
I tried to record a macro and ended up with this code
Sub Loop1()
'
' Loop1 Macro
'
'
Range("A4:E6").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A11:E13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A21").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A17:E19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A24").Select
ActiveSheet.Paste
End Sub
However, this turned out to be WAY more complicated then I expected.
I am looking for the end result to look like this
See if something like this works for you. I only ran one scenario through it so you will want to test it more.
This makes the assumption that the data is sorted by column B on the original sheet
This procedure makes an assumption that there is either headers or no data on row 1.
You will need to change the "Sheet1" in this line Set ws1 = ActiveWorkbook.Worksheets("Sheet1") to the name of the sheet you are starting with.
Option Explicit
Public Sub MoveData()
Dim ws1 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets.Add()
Dim rw As Long
Dim match_count As Integer
Dim list_multiplier As Integer
list_multiplier = 7
Dim list_row() As Long
ReDim list_row(0)
list_row(0) = 2
For rw = 2 To ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
If ws1.Range("B" & rw).Value <> ws1.Range("B" & rw).Offset(-1, 0).Value Then
match_count = 0
Else
match_count = match_count + 1
End If
Dim list_num As Integer
list_num = match_count \ 3
If list_num > UBound(list_row, 1) Then
ReDim Preserve list_row(list_num)
list_row(list_num) = 2
End If
ws2.Cells(list_row(list_num), 1 + list_multiplier * list_num).Value = ws1.Range("A" & rw).Value
ws2.Cells(list_row(list_num), 2 + list_multiplier * list_num).Value = ws1.Range("B" & rw).Value
ws2.Cells(list_row(list_num), 3 + list_multiplier * list_num).Value = ws1.Range("C" & rw).Value
ws2.Cells(list_row(list_num), 4 + list_multiplier * list_num).Value = ws1.Range("D" & rw).Value
ws2.Cells(list_row(list_num), 5 + list_multiplier * list_num).Value = ws1.Range("E" & rw).Value
list_row(list_num) = list_row(list_num) + 1
Next rw
End Sub
When you record your macro, ensure that "Use Relative References" on the Developer Ribbon tab is enabled, :)
assuming row 3 has your data headers, you could try this:
Option Explicit
Sub main()
Dim nLists As Long, iList As Long
Dim data As Variant
Dim dataToDelete As Range
With Range("F3", Cells(Rows.Count, 1).End(xlUp))
data = .Value
nLists = WorksheetFunction.Max(.Resize(,1))
nLists = nLists \ 3 + IIf(nLists - 3 * (nLists \ 3) = 0, -1, 0)
End With
With Range("A3").Resize(, 6)
For iList = 0 To nLists
Set dataToDelete = Nothing
With .Offset(, iList * 6).Resize(UBound(data))
.Value = data
.AutoFilter Field:=1, Criteria1:="<=" & iList * 3, Criteria2:=">" & (iList + 1) * 3, Operator:=xlOr
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set dataToDelete = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
If Not dataToDelete Is Nothing Then dataToDelete.Delete xlShiftUp
End With
Next
End With
End Sub
Your task is actually slightly trickier than your online advice suggests. Basically, you have to do the following:
Find out how many unique 'keys' (ie unique items in column B) you have. This will tell you the total number of rows you need (ie number of unique keys * 3)
Count the number of items for each 'key'. This will tell you how many columns you need (ie max item count / 3 * number of columns in array [A:E = 5])
Loop through each line of data and it put on appropriate row for that 'key'. Once three has been reached, jump the column for that key 6 columns to the right, and continue.
If you were to use a Class object and Collection type of object, this could be really quite concise code, but judging by your post you are at the beginning of your programming journey in VBA. Therefore, I've broken down each task into separate chunks of code so you will hopefully see how arrays can work for you. Once you practise with arrays a little, perhaps you could have a go at making this code more efficient by combining some of the loops:
Public Sub RunMe()
Dim data As Variant
Dim r As Long, c As Long, i As Long, dataRows As Long, dataCols As Long, keyLen As Long, maxCount As Long
Dim keys As String
Dim k As Variant
Dim keyArray() As String
Dim keyCount() As Long, threeCount() As Long, rowNum() As Long, colNum() As Long
Dim output() As Variant
'Read the data - change "Sheet1" to your sheet name.
'Shows how to write range values into a variant to
'create an array of variants.
data = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value2
dataRows = UBound(data, 1)
dataCols = UBound(data, 2)
'Create a list of unique keys.
'Note: not the most efficient way, but shows how to
'create an array from a value-separated string.
For r = 1 To dataRows
If InStr(keys, CStr(data(r, 2))) = 0 Then
If Len(keys) > 0 Then keys = keys & "|"
keys = keys & CStr(data(r, 2))
End If
Next
keyArray = Split(keys, "|")
keyLen = UBound(keyArray)
'Initialise the row and column numbers for each key.
'Shows how to iterate an array using For Each loop.
ReDim rowNum(keyLen)
ReDim colNum(keyLen)
r = 1
i = 0
For Each k In keyArray
rowNum(i) = r
colNum(i) = 1
r = r + 3
i = i + 1
Next
'Count the number of items for each key.
'Shows how to iterate an array using For [index] loop.
ReDim keyCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
keyCount(i) = keyCount(i) + 1
If keyCount(i) > maxCount Then maxCount = keyCount(i)
Next
'Size the output array.
c = WorksheetFunction.Ceiling(maxCount / 3, 1)
ReDim output(1 To (keyLen + 1) * 3, 1 To c * dataCols + c - 1)
'Populate the output array.
ReDim threeCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
'Copy the columns for this row.
For c = 1 To dataCols
output(rowNum(i), colNum(i) + c - 1) = data(r, c)
Next
'Increment the count and if it's equals 3 then
'reset the row num and increase the column number.
threeCount(i) = threeCount(i) + 1
rowNum(i) = rowNum(i) + 1
If threeCount(i) = 3 Then
rowNum(i) = rowNum(i) - 3
colNum(i) = colNum(i) + dataCols + 1
threeCount(i) = 0
End If
Next
'Write the data - change "Sheet2" to your sheet name.
'Shows how to write an array to a Range.
ThisWorkbook.Worksheets("Sheet2").Range("A3") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function IndexOfKey(list() As String, key As String) As Long
Dim i As Long
Dim k As Variant
'Helper function to find index position of key in array.
For Each k In list
If key = k Then
IndexOfKey = i
Exit Function
End If
i = i + 1
Next
IndexOfKey = -1
End Function
This code is now working to search multiple values in multiple sheets.
How can I fix it to support searching multiple values at the same time without having to write every one . For example, I want to put in column A all my search values, and then I click on search, and it should search and give the value for all of them at the same time. What should I change in the code to do this function?
Please see the code and the images.
Dim i, j, k, l, m, n, no_sheets As Variant
Dim key, cursor, sheetname As Variant
Dim flag As Variant
Dim sheet1_count, sheet1_row, row_count As Integer
Dim Arr() As Variant
sheet1_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("sheet1").Range("A:A"))
no_sheets = 3 ' Number of sheets
k = 2
sheet1_row = sheet1_count 'My start in result sheet
key = ThisWorkbook.Worksheets("sheet1").Range("A" & sheet1_count) ' The value that the user will put in searching sheet in column A
For i = 2 To no_sheets ' sheet2 then sheet3 then sheet4 then sheet5 ..etc
flag = False
sheetname = "Sheet" & i
row_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets(sheetname).Range("A:A")) ' It's a counter that will contain the range of row A in each sheet
For j = 1 To row_count 'I'll start from row 1 until the last sheet
cursor = ThisWorkbook.Worksheets(sheetname).Range("A" & j) 'Searching in column A in each sheet (1st row - last row) and put the value in this variable
If key = cursor Then ' If the entering value in sheet1 equal the value that we have in current sheet, do the following
' Copying the data
flag = True ' The data found
ThisWorkbook.Worksheets("sheet1").Range("A" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("A" & j)
ThisWorkbook.Worksheets("sheet1").Range("B" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("B" & j)
ThisWorkbook.Worksheets("sheet1").Range("C" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("C" & j)
ThisWorkbook.Worksheets("sheet1").Range("D" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("D" & j)
ThisWorkbook.Worksheets("sheet1").Range("E" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("E" & j)
ThisWorkbook.Worksheets("sheet1").Range("F" & sheet1_row) = ThisWorkbook.Worksheets(sheetname).Range("F" & j)
sheet1_row = sheet1_row + 1
Else
End If
Next j 'Go to the next row
Next i 'Go to the next sheet
MsgBox "finished, Do another search..!"
If key <> cursor Then
flag = False ' If the value not found
ThisWorkbook.Worksheets("sheet1").Range("B" & sheet1_row) = "Not found"
ThisWorkbook.Worksheets("sheet1").Range("C" & sheet1_row) = "Not found"
ThisWorkbook.Worksheets("sheet1").Range("D" & sheet1_row) = "Not found"
ThisWorkbook.Worksheets("sheet1").Range("E" & sheet1_row) = "Not found"
End If
End Sub
Sub MatchUnMatch_Click()
Dim i, j, k, l, m, n As Integer
Dim ListA_count, ListB_count, ListC_count, ListD_count, ListE_count As Integer
Dim key, cursor As String
Dim flag As Boolean
ListA_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("MatchUnmatch").Range("A:A"))
ListB_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("MatchUnmatch").Range("B:B"))
'ListA_count = ThisWorkbook.Worksheets("MatchUnMatch").Range("A2").End(xlDown).Row
'MsgBox ListA_count & " " & ListB_count
'=======================================================================================================
'
'
' Matching Logic for List 'A' and List 'B'
'
'
'=======================================================================================================
k = 2
For i = 2 To ListA_count
key = ThisWorkbook.Worksheets("MatchUnMatch").Range("A" & i)
For j = 1 To ListB_count
cursor = ThisWorkbook.Worksheets("MatchUnMatch").Range("B" & j)
'MsgBox "Key=" & Key & " Cursor=" & cursor
If key = cursor Then
ThisWorkbook.Worksheets("MatchUnMatch").Range("C" & k) = key
k = k + 1
Exit For
End If
Next j
Next i
'=======================================================================================================
'
'
' List 'A' items not in List 'B'
'
'
'=======================================================================================================
ListC_count = WorksheetFunction.CountA(ThisWorkbook.Worksheets("MatchUnmatch").Range("C:C"))
k = 2
For i = 2 To ListA_count
key = ThisWorkbook.Worksheets("MatchUnMatch").Range("A" & i)
flag = False
For j = 1 To ListC_count
cursor = ThisWorkbook.Worksheets("MatchUnMatch").Range("C" & j)
If key = cursor Then
flag = True
Exit For
End If
Next j
If flag = False Then
ThisWorkbook.Worksheets("MatchUnMatch").Range("D" & k) = key
k = k + 1
End If
Next i
'=======================================================================================================
'
'
' List 'B' items not in List 'A'
'
'
'=======================================================================================================
k = 2
For i = 2 To ListB_count
key = ThisWorkbook.Worksheets("MatchUnMatch").Range("B" & i)
flag = False
For j = 1 To ListC_count
cursor = ThisWorkbook.Worksheets("MatchUnMatch").Range("C" & j)
If key = cursor Then
flag = True
Exit For
End If
Next j
If flag = False Then
ThisWorkbook.Worksheets("MatchUnMatch").Range("E" & k) = key
k = k + 1
End If
Next i
End sub
see the image please, to understand what I meanI want to put in row A in search sheet (first sheet) many numbers and then I want to click on search button one time only that should give me all the values at the same time.I don't want to click one search more than one time.
I want someone to fix it for me please. As soon as possible :(
(*) updated after OP's requested functionality to save data from previous runs and have numbers not found in "data" sheets marked as "NOT FOUND"
(**) updated after OP's request to handle a variable number of columns
(***) updated to fix FindItems() function to handle non contiguous cells range
(****) updated to fix iRow updating in sub Main()
(*****) updated to have items to be searched in sheets whose cell "A1" has same content as that of "base" sheets
(******) updated to have items to be searched in column A of all data sheets, whatever the header of that column
While I was doing my code, Cornel's already given you an answer which is ok
however should you ever want to manage:
any different number of "data" Sheets (i.e.: sheets to seek for item number in its column "A" and gather relevant data from adjacent columns)
multiple occurrences of a "number" in any "data" sheet
(*) functionality to save previous data already in "base" sheet resulting from previous runs
(*) functionality to mark "NOT FOUND" in "base" sheet when number not found on any "data" sheet
(**) functionality to handle a variable number of columns
then you may want to use the following code
Option Explicit
Sub main()
Dim items() As Variant, itemToFind As Variant
Dim itemsNumber As Long, previousDataNumber As Long, dataShtNumber As Long, iRow As Long, i As Long, j As Integer
Dim itemsSht As Worksheet, dataShts() As Worksheet
Dim rngToCopy As Range
Dim itemFound As Boolean
Dim columnsNumberToCopyAndPaste As Long
columnsNumberToCopyAndPaste = 7 '<== here you set the number of columns to be copied form "data" sheet and pasted in "base" sheet
Set itemsSht = ThisWorkbook.Worksheets("Sheet1") ' this is the "base" sheet you take "numbers" from its column A, starting at row 2
Call GetItems(itemsSht, items(), itemsNumber, previousDataNumber) ' gather all "numbers" to be searched for in "data" sheets
Call GetDataWorksheets(dataShts(), ThisWorkbook, "Sheet1", dataShtNumber) ' gather all "data" sheets
iRow = 1
For i = 1 To itemsNumber 'loop through "numbers"
itemToFind = items(i) ' "number" to be searched for in "data" sheets
itemFound = False
For j = 1 To dataShtNumber 'loop through "data" worksheets
Set rngToCopy = FindItems(dataShts(j), itemToFind, 1, columnsNumberToCopyAndPaste) ' get "data" sheet column 1 cells with "number" along with 'columnsNumberToCopyAndPaste-1' adjacents cells
If Not rngToCopy Is Nothing Then ' if found any occurrence of the "number" ...
rngToCopy.Copy itemsSht.Cells(1, 1).Offset(previousDataNumber + iRow) ' ... copy it and paste into "base" sheet
iRow = iRow + rngToCopy.Count / columnsNumberToCopyAndPaste 'update "base" sheet row offset to paste subsequent cells, if any
itemFound = True
End If
Next j
If Not itemFound Then 'if NOT found any occurrence of the "number" ...
itemsSht.Cells(1, 1).Offset(previousDataNumber + iRow).Value = itemToFind
itemsSht.Cells(1, 2).Offset(previousDataNumber + iRow).Resize(1, columnsNumberToCopyAndPaste - 1).Value = "NOT FOUND"
iRow = iRow + 1
End If
Next i
itemsSht.Columns.AutoFit
End Sub
Sub GetItems(itemsSht As Worksheet, items() As Variant, itemsNumber As Long, previousDataNumber As Long)
With itemsSht
previousDataNumber = .Cells(.Rows.Count, 2).End(xlUp).Row - 1
itemsNumber = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 - previousDataNumber
ReDim items(1 To itemsNumber) As Variant
With .Cells(2 + previousDataNumber, 1).Resize(itemsNumber)
If itemsNumber = 1 Then
items(1) = .Value
Else
items = WorksheetFunction.Transpose(.Value)
End If
End With
End With
End Sub
Function FindItems(sht As Worksheet, itemToFind As Variant, columnToSearchFor As Long, columnsToCopy As Long) As Range
Dim cell As Range, unionRng As Range
Dim firstAddress As String
With sht.Columns(columnToSearchFor)
Set cell = .Find(What:=itemToFind, LookAt:=xlWhole)
If Not cell Is Nothing Then
firstAddress = cell.Address
Set unionRng = cell.Resize(, columnsToCopy)
Do
Set unionRng = Union(unionRng, cell.Resize(, columnsToCopy))
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
Set FindItems = unionRng
End If
End With
End Function
Sub GetDataWorksheets(shts() As Worksheet, wb As Workbook, noShtName As String, nShts As Long)
Dim sht As Worksheet
For Each sht In wb.Worksheets
With sht
If .Name <> noShtName Then
nShts = nShts + 1
ReDim Preserve shts(1 To nShts) As Worksheet
Set shts(nShts) = sht
End If
End With
Next sht
End Sub
(*) Actually I added a previousDataNumber variable to track data already there at the time the routine runs
(**) in columnsNumberToCopyAndPaste = 5 you set the number of columns to be handled
I split it into a "main" sub and some other "helper" subs or function in order to have clear and more maintainable/changeable code.
this habit has always helped me much more than I could ever expect at my beginnings, when I was used to code looong subs
Now I fully understand the problem, I have edited my initial Script. Now it includes a FINDNEXT loop after the first FIND, this searches all the duplicate values on the sheet. This loops until FINDNEXT.cell.address is the same as FIND.cell.address. To search only in column "A" I changed sheets(i).cells to sheets(i).Range("A:A") in the Find function
Sub find_cells()
Dim find_cell As Range
Dim colection_items As Collection
Dim look_up_value As String
nb_rows = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'count the number of rows with data on sheet(1)
Set colection_items = New Collection
For j = 2 To nb_rows
colection_items.Add Sheets(1).Cells(j, 1).Value
Next j
counter_rows = 2 'the first row on sheet(2) where we start copying data from
For col = 1 To colection_items.Count
look_up_value = colection_items(col)
For i = 2 To ThisWorkbook.Sheets.Count
Sheets(i).Select
Set find_cell = Sheets(i).Range("A:A").Find(What:=look_up_value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
If Not find_cell Is Nothing Then
Dim cell_adrs As String
cell_adrs = find_cell.Address 'record address of the first instance of the lookup value on the sheet (i)
Sheets(1).Cells(counter_rows, 1).Value = find_cell
Sheets(1).Cells(counter_rows, 2).Value = find_cell.Offset(0, 1) 'copies data from the cell to the left by one column
Sheets(1).Cells(counter_rows, 3).Value = find_cell.Offset(0, 2) 'copies data from the cell to the left by 2 columns
'etc
counter_rows = counter_rows + 1
Do
Set find_cell = Sheets(i).Range("A:A").FindNext(find_cell) 'we lookup the next instance on sheet (i)
If cell_adrs <> find_cell.Address Then 'if the next value found is different than the first value from sheet(i)
Sheets(1).Cells(counter_rows, 1).Value = find_cell
Sheets(1).Cells(counter_rows, 2).Value = find_cell.Offset(0, 1) 'copies data from the cell to the left by one column
Sheets(1).Cells(counter_rows, 3).Value = find_cell.Offset(0, 2) 'copies data from the cell to the left by 2 columns
counter_rows = counter_rows + 1
'etc
End If
Loop Until cell_adrs = find_cell.Address 'when all the values have been found and find_cell goes back to the first value
cell_adrs = Empty
End If
Next i
Next col
Sheets(1).Select
End Sub
I would like to be able to add some range of data in a dynamic multidimensional array without using a double loop that screens each element of the array. But I don't know if it is possible. By double loop, I mean such a code (this is only an example):
Dim Films(1 To 5, 1 To 2) As String
Dim i As Integer, j As Integer
For i = 1 To 5
For j = 1 To 2
Films(i, j) = Cells(i, j).Value
Next j
Next i
I am using VBA 2010. I know how many rows my array has, but the number of columns is variable.
Here is my code :
Sub DRS(Item)
'item is a name to search for in a specific range
Dim SrcRange() As Variant
Dim cell3 As Range
Dim n As Integer, m As Integer
SrcRange() = Array()
ReDim SrcRange(45, 0)
m = -1
n = 0
With Sheets("X")
For Each cell3 In .Range("I13:AG" & .Cells(1, Columns.Count).End(xlToRight).Column)
'the range ("I13:AG...") contains names, and some will match with "item"
m = m + 1
If Len(cell3.Value) > 0 And cell3 = Item Then
SrcRange(0, n) = .Range(m + 8 & "30:" & m + 8 & "75")
'the previous line **should** add a whole range of cells (which contain numbers, one by cell) in a colum of the array, but this is the line that doesn't work.
n = n + 1
ReDim Preserve SrcRange(UBound(SrcRange), n)
End If
Next cell3
End With
End Sub
I already tried those::
SrcRange(:, n) = .Range(m + 8 & "30:" & m + 8 & "75")
SrcRange(0:45, n) = .Range(m + 8 & "30:" & m + 8 & "75")
SrcRange(, n) = .Range(m + 8 & "30:" & m + 8 & "75")
but no one worked.
Is there a way or a formula that would allow me to add a full range of cells to each column of the array, or am I obliged to use a double loop to add the elements one by one?
I'm guessing that this Range...
.Range("I13:AG" & .Cells(1, Columns.Count).End(xlToRight).Column)
...should actually be xlToLeft instead of xlToRight (xlToRight will always return I13:AG16384).
I'm also not entirely sure what the m + 8 & "30:" & m + 8 & "75" is supposed to be evaluating to, because you increment the variable m each time through the loop, and it gives you ranges like 930:975. I'll take a stab in the dark and assume that the m + 8 is supposed to be the column that you found the item in.
That said, the .Value property of a Range object will just give you a 2 dimensional array. There isn't really any reason to build an array - just build a range and then worry about getting the array out of it when you're done. To consolidate the range (you only get the first area if you grab its Value), just copy and paste it to a temporary Worksheet, grab the array, then delete the new sheet.
Sub DRS(Item)
'item is a name to search for in a specific range
Dim SrcRange() As Variant
Dim found As Range
Dim cell3 As Range
With Sheets("X")
For Each cell3 In .Range("I13:AG" & .Cells(1, Columns.Count).End(xlToLeft).Column)
'the range ("I13:AG...") contains names, and some will match with "item"
If Len(cell3.Value) > 0 And cell3.Value = Item Then
If Not found Is Nothing Then
Set found = Union(.Range(.Cells(30, cell3.Column), .Cells(75, cell3.Column)), found)
Else
Set found = .Range(.Cells(30, cell3.Column), .Cells(75, cell3.Column))
End If
End If
Next cell3
End With
If Not found Is Nothing Then
Dim temp_sheet As Worksheet
Set temp_sheet = ActiveWorkbook.Sheets.Add
found.Copy
temp_sheet.Paste
SrcRange = temp_sheet.UsedRange.Value
Application.DisplayAlerts = False
temp_sheet.Delete
Application.DisplayAlerts = True
End If
End Sub