I'm having trouble with a specific process.
In column H, there are a bunch of different numbers. I'm looking for a loop, that for each newfound value in the column, counts how many times the value occur in that column, and put's the counted value in the next worksheet "Statistik".
I do have a solution were I make a code for each individual number in the column, but i'm looking for a loop, since there are 28 different values ind that column.
Image of my workbook
Does anyone have a bright solution for my problem?
Thanks in advance.
You need to use COUNTIF. Either as a formula or in your VBA code (Application.CountIf()).
In your case =COUNTIF(H:H, [UNIQUE_VALUE]) where unique value is the value you want to extract. To get unique values you have two options. One is to copy unique values from H:H to your Statistik sheet as follows:
Click the Data Ribbon Menu
Select the Advanced Button in the Sort & Filter section
Fill in the dialog Box, Copy to another location, List range H:H, Copy to Some column in Statistik sheet* making sure you tick **Unique records only
Other option to get unique values is detailed here https://exceljet.net/formula/extract-unique-items-from-a-list
For more information about COUNTIF
https://support.office.com/en-us/article/countif-function-e0de10c6-f885-4e71-abb4-1f464816df34
You could use a dictionary to output only 1 key and value
Option Explicit
Public Sub GetCount()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1") 'change as appropriate
Dim arr(), i As Long
arr = Intersect(.Columns("H"), .UsedRange) '<=== Specify exact range in H to loop over if you want including header
For i = LBound(arr, 1) + 1 To UBound(arr, 1) 'assuming header to ignore otherwise start at 1
If Not dict.exists(arr(i, 1)) Then
dict.Add arr(i, 1), 1 '<==== if value not seen before add to dictionary with value of 1
Else
dict(arr(i, 1)) = dict(arr(i, 1)) + 1 ' <====== if seen before add 1 to the existing count
End If
Next i
End With
With Worksheets("Statistik")
.Range("A1") = "StudyBoard_ID"
.Range("B1") = "Count"
.Range("A2").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
.Range("B2").Resize(dict.Count, 1) = Application.Transpose(dict.Items)
End With
End Sub
Related
I have tried so many methods from the removeduplicates, selections and scripting dictionaries and I cannot get this to work. I do understand there are multiple ways to do this but if any of you can help, that would be great.
I have one list of values that I am pulling through from another sheet (up to approx 80k rows) into cell B13 downwards. I am then trying to remove the duplicate values and cells so I am left with unique values which I can then use to perform lookups on other sheets.
Sub Address_Sage()
Dim dataBook As Workbook
Dim dict As Object
Dim Sage_Data As Worksheet, Address As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Dim rowCount As Long
Dim strVal As String
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Sage_Data")
Set sheetDest = dataBook.Sheets("Address")
Set dict = CreateObject("Scripting.Dictionary")
Set dataSource = sheetSource.Range("A3", _
sheetSource.Range("A90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
Next index
Sheets("Address").Select
rowCount = ActiveSheet.Range("B13").CurrentRegion.Rows.Count
Do While rowCount > 0
strVal = Address.Cells(rowCount, 1).Value2
If dict.exists(strVal) Then
ActiveSheet.Rows(rowCount).EntireRow.Delete
Else
dict.Add strVal, 0
End If
rowCount = rowCount - 1
Loop
'Set dict = Nothing
End Sub
It always gets stuck on strVal line. I have tried changing value2 to value1 as I only have column but no luck.
thank you
Not super experienced in VBA so I can't speak to exactly what you're doing and what your code is saying but I thought I'd share this with you. Last week I had to create a macrobook that returned the unique entries of electrical defects that different crews observed while on the job. I made a dictionary that read all of the entries in the spreadsheet and then later printed all of the unique entries. I'll post the code and try to walk you through it.
If .Range("A" & i) <> "" Then
If dict.Exists(data) Then
dict(data) = dict(data) + 1
Else
dict.Add Key:=Data, Item:="1"
End If
End If
So the code basically says if column A (i is simply an incrementer) is not empty, then we're going to read the entries of column A. Data is simply a variable and you would set it equal to the range of values you'd like read in the dictionary. Obviously dictionary keys are unique and cannot repeat, so the code asks if the key already exists in the dictionary. If so, we will add one to it's count or value. And if not we will add that key to the dictionary. At the end of your loop, your dictionary will have stored all unique entries and the number of times they appeared.
Now we can reference them or print them.
For r = 0 To dict.Count
Sheets("Results").Range("B" & iResults) = dict.Keys(r)
Sheets("Results").Range("C" & iResults) = dict(dict.Keys(r))
Next
This second piece of code is a loop from 0 to the number of entries in your dictionary. It starts at zero because the dictionary is stored like an array and VBA arrays are base zero. The first statement will print the unique keys for every r until there are no more entries in the dictionary. The second statement will print the value or items associated with them. It will be an integer value equal to the number of times that unique entry showed up in your data.
You can use this same method for other purposes as well, not just printing the data but referencing it and using it somewhere else. But I am sure you will find that the For-loop with dict.Keys(r) is the easiest way to run through your dictionary entries. Took me a few days to figure it out and it revolutionized my program. Hope this helps you out.
I have a list of data to which I would like to add comments based on older versions of the list which is another worksheet in the same workbook.
Now I tried an approach with two loops (the first one actually looking if there was a comment in a given row and then the second looking for the criterias in every row of the new sheet and adding a comment if necessary) but it turned out way too slow. There are around 15 000 entries in each sheet and around 6500 entries with comments in the older sheets.
I need a faster way for getting the comments from the old sheet to the new sheet. As you can see, certain combinations of criterias in the older sheets might have multiple corresponding combinations in a newer sheet. In that case, I need the comment in ALL rows that fit the criteria.
Use a Scripting.Dictionary object to identify the a unique list of the first two columns while collecting a list of the comments IDs.
Option Explicit
Sub copyCommentIDs()
Dim a As Long, b As Long, aCOMs As Variant, k As Variant
Dim d As Long, dCOMs As Object
Set dCOMs = CreateObject("Scripting.Dictionary")
dCOMs.comparemode = vbTextCompare
With Worksheets("Sheet19")
'collect data from Old Sheet into an array
aCOMs = .Range(.Cells(3, "E"), .Cells(.Rows.Count, "G").End(xlUp)).Value2
End With
'build dictionary; collect comment IDs
For a = LBound(aCOMs, 1) To UBound(aCOMs, 1)
'if there a comment ID?
If CBool(Len(Trim(aCOMs(a, 3)))) Then
'concatenate/deliminate the first two columns
k = Join(Array(aCOMs(a, 1), aCOMs(a, 2)), ChrW(8203))
'does it exist in the dictionary?
If dCOMs.exists(k) Then
'it exists; concatenate the comment id onto the dict. key's item
dCOMs.Item(k) = Join(Array(dCOMs.Item(k), aCOMs(a, 3)), ", ")
Else
'does not exist; add a new dict key/item pair
dCOMs.Item(k) = aCOMs(a, 3)
End If
End If
Next a
With Worksheets("Sheet19")
'return the dictionay items to the new sheet
For b = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
'concatenate/deliminate the first two columns
k = Join(Array(.Cells(b, "A").Value2, .Cells(b, "B").Value2), ChrW(8203))
'does it exist in the dictionary?
If dCOMs.exists(k) Then
'transfer the comment id
.Cells(b, "C") = dCOMs.Item(k)
End If
Next b
End With
'clean up
Erase aCOMs
dCOMs.RemoveAll: Set dCOMs = Nothing
End Sub
I have an Excel table.
And I need to write its data into a single column, row by row, every row is "read" from left to right, zeroes excluded. Please look at the picture to understand better:
Is there a way to do it quickly using VBA? I tried using only formulas and it worked, but it took several steps (creating a column, excluding zeroes, re-writing the column...) and really slowed down the whole process.
To copy all the non empty values from a range to a single column:
Dim source(), arr(), r&, c&, i&
' read the data from the range
source = [A1:G3].Value2
' copy the non empty value
ReDim arr(1 To UBound(source, 1) * UBound(source, 2), 1 To 1)
For r = 1 To UBound(source, 1)
For c = 1 To UBound(source, 2)
If source(r, c) <> Empty Then
i = i + 1
arr(i, 1) = source(r, c)
End If
Next
Next
' write the data back to the sheet
[A7].Resize(i, 1) = arr
I have the following code that counts the number of cells in a column that contains the string, "ABC-QR":
Ctr = Application.WorksheetFunction.CountIf(Sheet1.Range("D4:D1500"), "*ABC-QR*")
EU.Cells(16, 3) = Ctr
I used "ABC-QR" because that's the part of the data that doesn't change. The true data that's in those cells is, for example, "ABC-QR00012345", or whatever number it may have. I would like to modify my code to not include duplicates when it's counting.
Firstly, you must enable 'Microsoft Scripting Runtime' from within Tools --> References within the Visual Basic Editor.
You assign the data from the worksheet into an array; then import everything which fits the string criteria, and isn't a duplicate, into a dictionary. You can check for duplicates in the dictionary using the .Exists method.
EDIT: As noted by #Zev in the comments, you don't even need to use the .Exists method. You can just assign the array element to the key of the dictionary, and assign the item value as 1. Any duplicate values from the Array will overwrite the previous key, so duplicates will automatically be dealt with.
Once everything which isn't a duplicate has been imported into the dictionary, you can then use the .Count property on the dictionary. This will tell you how many records fit your string criteria, and are not duplicates, within the range passed into the array.
Option Explicit
Sub countNonDuplicates()
Dim wb As Workbook, ws As Worksheet
Dim dict As Scripting.Dictionary
Dim myValues() As Variant
Dim lRow As Long, i As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set dict = New Scripting.Dictionary
lRow = Cells(Rows.Count, 1).End(xlUp).Row
myValues = Range(Cells(1, 1), Cells(lRow, 1))
For i = 1 To UBound(myValues, 1)
If InStr(myValues(i, 1), "ABC-QR") Then dict(myValues(i,1)) = 1 'arbitrary value
Next i
MsgBox (dict.Count)
End Sub
The above currently gets the last row of Column A and then takes the range and assigns it to the array. If you wish to use a different column, then update the following statements with the column number required (example below now uses Column D)
lRow = Cells(Rows.Count, 4).End(xlUp).Row
myValues = Range(Cells(1, 4), Cells(lRow, 4))
Also it's currently performing the above on Sheets(1). Change the worksheet number to what you require.
On 100,000 records this took 0.2 seconds to produce the count.
This array formula should do the trick:
EU.Cells(16,3).FormulaArray = "=SUM(IF(ISERROR(FIND(""ABC-QR"",D4:D1500)),0,1/(COUNTIF(D4:D1500,D4:D1500))))"
Since it's an array formula, it will operate on each cell in your range in turn and look for your text (FIND("ABC-QR",D4:D1500)). If it's not found, it returns 0 to the running SUM(). If it is found, it uses the value 1/count, where count is the number of times the cell value being tested exists in your range.
I have multiple spreadsheets that each roughly look like this:
I'm trying to find a way to go through each of the SPEAKER HEADERS in Row 1, and summarize the scores that are associated with the corresponding survey question ("Was the CONTENT good? Was the SPEAKER relevant? What the DELIVERY good?) grouped by color.
I can't think of a clever way of doing this automatically.
I can get the RANGE SPANS of the Merged Cells like this:
For Each Cell In src_sheet.UsedRange.Cells
If Cell.Row = 1 And IsEmpty(Cell) = False Then
MsgBox Cell.MergeArea.Address
End If
Next
I then need to iterate over the range provided by the address, getting the numerical values in all the rows BELOW that range.
For example, running the current macro produces this:
I need to take $C$1:$E$1 and run a for loop that say FROM C1 to E1 average all the numbers in the rows below it. I have no idea how to do this.
I was thinking about augmenting the selection in include everything used
Is there a better way to do this?
This is the tragically bad way I'm doing it now (which I'm quite proud of on account of being new to excel):
For Each Cell In src_sheet.UsedRange.Cells
If Cell.Row = 1 And IsEmpty(Cell) = False Then
Set rng = Range(Cell.MergeArea.Address) 'Equal to the Address of the Merged Area
startLetter = Mid(rng.Address, 2, 1) 'Gets letter from MergeArea Address
endLetter = Mid(rng.Address, 7, 1) 'Gets letter from MergeArea Address
On Error GoTo ErrHandler:
Set superRange = Range(startLetter & ":" & endLetter)
ErrHandler:
endLetter = startLetter
Set superRange = Range(startLetter & ":" & endLetter)
Resume Next
superRange.Select
MsgBox Application.Average(Selection)
In order to get rid of the error you are having, you need to change:
Set rng = Cell.MergeArea.Address
to
Set rng = Range(Cell.MergeArea.Address)
Ideally, this data would be better stored in a database so that it could be queried easily. If that's not an option, then the way you are going at it in Excel is as valid as most any other approach.
EDIT
Once you obtain the address of the left-most column for each of your speakers, you can loop through each column to obtain averages.
'Number of columns in the current speaker's range.
numColumns = rng.Columns.Count
'First row containing data.
currentRow = 4
'First column containing data.
firstColumn = rng.Column
'Loop through each column.
For col = firstColumn to firstColumn + (numColumns -1)
totalValue = 0
'Loop through each row.
Do While Cells(currentRow,col).value <> ""
totalValue = totalValue + Cells(currentRow,col).Value
currentRow = currentRow + 1
Loop
averageValue = totalValue / (currentRow - 3)
'Reset the currentRow value to the top of the data area.
currentRow = 4
'Do something with this average value before moving on to the next column.
Next
If you don't know what row is the start of your data, you can keep checking every row below rng.Row until you hit a numeric value.
The method above assumes that you have no blank entries in your data area. If you have blank entries, then you should either sort the data prior to running this code, or you would need to know how many rows you must check for data values.