So I have two columns 17&18 where I have multiple rows such as:
17 | 18<br>
ttt | xxx<br>
tty | xxy<br>
eer | eet<br>
fff | fft<br>
etc...
What I want to do is start at Row 2 Column 17, grab ttt and then see if that occurs again in either column 17 or 18. If it doesn't I need to display a message to the user and if it does, say Row 20 Column 18 I need to ignore it and mark that I've already found this value and don't want to come across it again when I get down there.
I hope this makes sense ...
I think the right thing to do is to use a Do loop and look at something like:
Dim X As Range
Do While Cells(X, 17) <> ""
Do While Cells(X,18) <> ""
Cells.Find(What:=X.Value, After:=activeCell).Active
Loop
Loop
Has anyone tried to do this before?
I wouldn't use the range .Find method for this. Use simply the Application.Match function or the WorksheetFunction.CountIf function. In order to ignore it on second/subsequent passes, you will need to store the list of values to ignore in memory, I would recommend using a dictionary object for this.
Something like this perhaps (untested):
Sub foo()
Dim column1 as Range
Dim rngToCheck as Range
Dim r as Range
Dim dict as Object
'use a dictionary object to keep track of the items that appear more than once
Set dict = CreateObject("Scripting.Dictionary")
Set column1 = Range("A1:A100") 'Modify as needed -- only the first column
Set rngToCheck = Range("A1:B100") 'Modify as needed -- both columns
'Check each value in column1 against the entire range
For each r in column1
'ignoring anything that already has been added to the dictionary
If not dict.Exists(r.Value) Then
If WorksheetFunction.CountIf(rngToCheck, r.Value) > 1 then
'if it appears more than once then add it to the dictionary so to ignore
' it the next time the macro encounters this value:
dict(r.Value) = dict(r.Value)
Else
'if this value only appears once, then it doesn't appear anywhere else, _
' so msgbox to the user. Modify msgbox as needed:
MsgBox r
End If
End If
Next
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.
Say I have a large discontiguous range defined, perhaps Range("B:B,E:E,F:F"). How would I go about indexing into the range to treat it as if it were contiguous.
E.g. I'd like to do something like
Set myRange = Range("B:B,E:E,F:F")
v = myRange.ContiguousIndex(5, 3).Value 'retrieves the value in cell F5 (row 5 col 3)
Every method I'm aware of will offset based on the first cell in the range ("B1") and will gladly go out of the bounds of that range, spilling over into the rest of the contents of the workbook. This means that trying to access row 5, col 3 would get you D5, as if columns C and D were in the range I'm trying to index.
I've tried Range.Cells, Range.Offset, and Range.Range, but all seem to exhibit this same spillover.
The other approach I had in mind was to assign the values to a variant array and manually index from there, but this becomes complicated very quickly because a simple snippet like
Dim v() As Variant
v = myRange
will only assign the first area of the discontiguous range into the array, leaving me with an (20^20-1)x1 array and completely ignoring the rest of myRange. So it's probably doable to get the whole myRange into an array if I loop through all the areas and individually assign them into an array I keep reallocating, but it's far from easy and I end up with an array that uses far more memory than I want (unless I put more overhead into trimming it down or I arbitrarily choose a smaller number of rows to copy).
At that point, it would be far more efficient and simple to just loop through the areas manually and do the indexing myself without all the cost of putting things into an array. This final approach is what I'm currently doing.
The Question
Is there any existing method or trick I can use to treat myRange as if it were contiguous in the way I described and to index into myRange in a way that ignores the discontinuities?
TL;DR If I have
Set myRange = Range("B:B,E:E,F:F")
v = myRange.ContiguousIndex(5, 3).Value
I want some method ContiguousIndex to return Range("F5").Value without having to do all the work of manually checking Range.Areas and handling all the indexing.
Bonus Question
Say myRange were Range("E:E,B:B,F:F") (notice the different column order). Is there a nice way to treat E as the first column, B as the second, and F as the third, such that
Set myRange = Range("E:E,B:B,F:F")
v = myRange.ContiguousIndex(5, 2).Value 'retrieves the value in cell B5
returns the value of B5? This is a property of the method I'm using that I'd love to continue having.
Again, the function I have works, but I'm guessing that there's some kind of wonderful method or trick hidden away in all of Excel's quirks that would be even better.
I'm going to post up my own solution in case anyone else runs into a similar problem. This is the only one that worked for me, as the other answers and comments rely on knowing something about the Areas in the range (e.g. relying on each Area being an entire single column, which I couldn't guarantee because my ranges were user-input and could span multiple columns or a finite number of rows).
' Indexes into a discontiguous area as expected, ignoring cells not in Range r
' and treating areas as concatenated (and top-aligned) in the order they are specified
Public Function ContiguousIndex(r As Range, row As Long, col As Long)
Dim area As Range
For Each area In r.Areas
If col <= area.Columns.count Then
If row <= area.Rows.count Then
ContiguousIndex = area.Cells(row, col)
Exit Function
Else
Err.Raise vbObjectError + 9, , "Row Index out of bounds"
End If
Else
col = col - area.Columns.count
End If
Next
' col argument > sum of all cols in all areas
Err.Raise vbObjectError + 9, , "Col Index out of bounds"
End Function
It's worth rementioning something I covered in the comments, but might be unexpected: this code will top-align all areas such that the first row in area 1 is at the same index as the first row in area 2 is the same... etc. This leads to a quirk when calling something like ContiguousIndex(Range("A1:B7,A8:B10"), 9, 2). While it seems obvious this should return B9, this isn't the case - it will actually try to access the 9th row, 2nd column of A1:B7, resulting in an error. That's because the two discontiguous ranges, although they are clearly arranged top-to-bottom on the actual sheet, are treated as if they are side-to-side. So B9 is accessible via the command ContiguousIndex(Range("A1:B7,A8:B10"), 2, 4) (unintuitively). This behavior is what I required, but it might not be what you expect.
In order to circumvent this, you can use the built-in Application.Union or Application.Intersect methods. These automatically collapse contiguous regions when possible. All of the following work:
' Every statement will print "A1:B10" - the areas are merged
' Union of separate areas
Debug.Print Union(Range("A1:B7"), Range("A8:B10")).Address
' Union of range with a known subrange
Debug.Print Union(Range("A1:B7,A8:B10"), Range("A1:B7,A8:B10").Cells(1, 1)).Address
' Union of range with itself
Debug.Print Union(Range("A1:B7,A8:B10"), Range("A1:B7,A8:B10")).Address
' Intersect of range with itself
Debug.Print Intersect(Range("A1:B7,A8:B10"), Range("A1:B7,A8:B10")).Address
If this is the desired behavior when indexing, then perform one of the listed merges before calling ContiguousIndex. Do note that if areas are unmerged in the union operation, their relative discontiguous indices are left unchanged. E.g.
' Yields "A:A,F:F,C:D" not "A:A,C:D,F:F" as you might desire
Debug.Print Union(Range("A:A,F:F,C:C,D:D"), Range("A:A,F:F,C:C,D:D")).Address
Something to note is that with .Cells / .Rows / .Columns / ._Default you can get values outside of your range:
Set myRange = Range("E2:E4,C4:B2,F2:F4") ' C4:B2 gets B2:C4
Debug.Print myRange.Areas(2)(1).Address ' $B$2
Debug.Print myRange.Areas(2)(0, 0).Address ' $A$1
Debug.Print myRange.Areas(2).Cells(0, 0).Address ' $A$1
Debug.Print myRange.Areas(2).Rows(0).Columns(0).Address ' $A$1
If instead you index the values:
Debug.Print myRange.Areas(2).Value2(1, 1) ' value of B2
Debug.Print myRange.Areas(2).Value2(0, 0) ' Run-time error '9': Subscript out of range
If by any chance you have areas with multiple columns like "E:E,A:B" it will be a bit easier to index them if you specify each column as a separate area : "E:E,A:A,B:B"
I think I understand your question a bit better after seeing your example. It can be "simplified" a tiny bit by enumerating the columns instead of the ranges:
Public Function ContiguousIndex(r As Range, row As Long, col As Long) As Range
Dim column As Range
For Each column In r.Columns
If col > 1 Then
col = col - 1
ElseIf col = 1 Then
If row <= column.Rows.Count And row > 0 Then
Set ContiguousIndex = column.Rows(row)
Exit Function
End If
Err.Raise vbObjectError + 9, , "Row Index out of bounds"
ElseIf col < 1 Then
Err.Raise vbObjectError + 9, , "Column Index out of bounds"
End If
Next
End Function
I could not find a way to access the enumerator directly ( for example
r.Columns.[_NewEnum].Item(col) does not work )
Update
Just for example
Public Function veryContiguousIndex(r As Range, row As Long, col As Long) As Range
Dim cell As Range, i As Long: i = col * row
For Each cell In r.Cells
If i = 1 Then Set veryContiguousIndex = cell: Exit Function
i = i - 1
Next
End Function
then
Dim r As Range: Set r = [A1:B7,A8:B10]
Debug.Print r.Cells.Count; r.Columns.Count; r.Rows.Count ' 20 2 7
Debug.Print veryContiguousIndex(r , 9, 2).Address(0, 0) ' B9
Debug.Print veryContiguousIndex(r.EntireColumn, 9, 2).Address(0, 0) ' B9
Debug.Print veryContiguousIndex(r.EntireRow , 9, 2).Address(0, 0) ' R1
How about:
v = myRange.Areas(2).Rows(5).Value 'retrieves the value in cell B5
This appears to work for the both the original and bonus questions as long as each sub-range is a single column. You could also create a simple wrapper function ContiguousIndex(Row,Column) in VBA to give the interface you described.
Hope that helps.
I have a rather complicated problem.
I have a log file that when put into excel the column "I" contains event IDs, and the column J contains a custom key that keeps a particular even grouped.
All i want to do is remove any rows that do not contain the value of say 102 in the event id column.
And THEN i need to check the custom key (column J) and remove rows that are duplicates since any duplicates will falsely show other statistics i want.
I have gotten as far as being able to retrieve the values from the columns using com objects and .entirecolumn cell value etc, but I am completely stumped as to how i can piece together a solid way to remove rows. I could not figure out how to get the row for each value.
To give a bit more clarity this is my thought process on what i need to do:
If cell value in Column I does not = 102 Then delete the row that cell contains.
Repeat for all rows in spreadsheet.
And THEN-
Read every cell in column J and remove all rows containing duplicates based on the values in column J.
Save spreadsheet.
Can any kind persons help me?
Additional Info:
Column I holds a string that is an event id number e.g = 1029
Column J holds a string that is a mix of numbers and letters = 1ASER0X3NEX0S
Ellz, I do agree with Macro Man in that your tags are misleading and, more importantly, I did indeed need to know the details of Column J.
However, I got so sick of rude posts today and yours was polite and respectful so I've pasted some code below that will do the trick ... provided Column J can be a string (the details of which you haven't given us ... see what Macro Man's getting at?).
There are many ways to test for duplicates. One is to try and add a unique key to a collection and see if it throws an error. Many wouldn't like that philosophy but it seemed to be okay for you because it also gives you a collection of all the unique (ie remaining) keys in Column J.
Sub Delete102sAndDuplicates()
Dim ws As Worksheet
Dim uniques As Collection
Dim rng As Range
Dim rowPair As Range
Dim iCell As Range
Dim jCell As Range
Dim delRows As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rng = Intersect(ws.UsedRange, ws.Range("I:J"))
Set uniques = New Collection
For Each rowPair In rng.Rows
Set iCell = rowPair.Cells(, 1)
Set jCell = rowPair.Cells(, 2)
On Error Resume Next
uniques.Add jCell.Value2, jCell.Text
If Err = 457 Or iCell.Value2 = 102 Then
On Error GoTo 0
If delRows Is Nothing Then
Set delRows = rowPair.EntireRow
Else
Set delRows = Union(delRows, rowPair.EntireRow)
End If
End If
Next
If Not delRows is Nothing then
MsgBox delRows.Address(False, False) & " deleted."
delRows.Delete
End If
End Sub
There are a number of ways in which this can be done, and which is best will depend on how frequently you perform this task and whether you want to have it fully automated. Since you've tagged your question with VBA I assume you'll be happy with a VBA-based answer:
Sub removeValues()
Range("I1").Select 'Start at the top of the I column
'We are going to go down the column until we hit an empty row
Do Until IsEmpty(ActiveCell.Value) = True
If ActiveCell.Value <> 102 Then
ActiveCell.EntireRow.Delete 'Then delete the row
Else
ActiveCell.Offset(1).Select 'Select the cell below
End If
Loop
'Now we have removed all non-102 values from the column, let`s remove the duplicates from the J column
Range("A:J").RemoveDuplicates Columns:=10, Header:=xlNo
End Sub
The key line there is Range("A:J").RemoveDuplicates. It will remove rows from the range you specify according to duplicates it finds in the column you specify. In that case, it will remove items from the A-J columns based on duplicates in column 10 (which is J). If your data extends beyond the J column, then you'll need to replace "A:J" with the appropriate range. Note that the Columns value is relative to the index of the first column, so while the J column is 10 when that range starts at A (1), it would be 2 for example if the range were only I:J. Does that make sense?
(Note: Using ActiveCell is not really best practice, but it's the method that most obviously translates to what you were trying to do and as it seems you're new to VBA I thought it would be the easiest to understand).
I have an excel which serves to record the food you ingest for a specific day and meal. I hav a grid in which each line represent a food you ate, how much sugar it has, etc.
Then i've added an save button to save all the data to a table in another sheet.
This is what i have tried
Public Sub addDataToTable(ByVal strTableName As String, ByRef arrData As Variant)
Dim lLastRow As Long
Dim iHeader As Integer
Dim iCount As Integer
With Worksheets(4).ListObjects(strTableName)
'find the last row of the list
lLastRow = Worksheets(4).ListObjects(strTableName).ListRows.Count
'shift from an extra row if list has header
If .Sort.Header = xlYes Then
iHeader = 1
Else
iHeader = 0
End If
End With
'Cycle the array to add each value
For iCount = LBound(arrData) To UBound(arrData)
**Worksheets(4).Cells(lLastRow + 1, iCount).Value = arrData(iCount)**
Next iCount
End Sub
but i keep getting the same error on the highlighted line:
Application-defined or object-defined error
What i am doing wrong?
Thanks in advance!
You don't say which version of Excel you are using. This is written for 2007/2010 (a different apprach is required for Excel 2003 )
You also don't say how you are calling addDataToTable and what you are passing into arrData.
I'm guessing you are passing a 0 based array. If this is the case (and the Table starts in Column A) then iCount will count from 0 and .Cells(lLastRow + 1, iCount) will try to reference column 0 which is invalid.
You are also not taking advantage of the ListObject. Your code assumes the ListObject1 is located starting at row 1. If this is not the case your code will place the data in the wrong row.
Here's an alternative that utilised the ListObject
Sub MyAdd(ByVal strTableName As String, ByRef arrData As Variant)
Dim Tbl As ListObject
Dim NewRow As ListRow
' Based on OP
' Set Tbl = Worksheets(4).ListObjects(strTableName)
' Or better, get list on any sheet in workbook
Set Tbl = Range(strTableName).ListObject
Set NewRow = Tbl.ListRows.Add(AlwaysInsert:=True)
' Handle Arrays and Ranges
If TypeName(arrData) = "Range" Then
NewRow.Range = arrData.Value
Else
NewRow.Range = arrData
End If
End Sub
Can be called in a variety of ways:
Sub zx()
' Pass a variant array copied from a range
MyAdd "MyTable", [G1:J1].Value
' Pass a range
MyAdd "MyTable", [G1:J1]
' Pass an array
MyAdd "MyTable", Array(1, 2, 3, 4)
End Sub
Tbl.ListRows.Add doesn't work for me and I believe lot others are facing the same problem. I use the following workaround:
'First check if the last row is empty; if not, add a row
If table.ListRows.count > 0 Then
Set lastRow = table.ListRows(table.ListRows.count).Range
For col = 1 To lastRow.Columns.count
If Trim(CStr(lastRow.Cells(1, col).Value)) <> "" Then
lastRow.Cells(1, col).EntireRow.Insert
'Cut last row and paste to second last
lastRow.Cut Destination:=table.ListRows(table.ListRows.count - 1).Range
Exit For
End If
Next col
End If
'Populate last row with the form data
Set lastRow = table.ListRows(table.ListRows.count).Range
Range("E7:E10").Copy
lastRow.PasteSpecial Transpose:=True
Range("E7").Select
Application.CutCopyMode = False
Hope it helps someone out there.
I had the same error message and after lots of trial and error found out that it was caused by an advanced filter which was set on the ListObject.
After clearing the advanced filter .listrows.add worked fine again.
To clear the filter I use this - no idea how one could clear the filter only for the specific listobject instead of the complete worksheet.
Worksheets("mysheet").ShowAllData
I actually just found that if you want to add multiple rows below the selection in your table
Selection.ListObject.ListRows.Add AlwaysInsert:=True works really well. I just duplicated the code five times to add five rows to my table
I had the same problem before and i fixed it by creating the same table in a new sheet and deleting all the name ranges associated to the table, i believe whene you're using listobjects you're not alowed to have name ranges contained within your table hope that helps thanks
Ran into this issue today (Excel crashes on adding rows using .ListRows.Add).
After reading this post and checking my table, I realized the calculations of the formula's in some of the cells in the row depend on a value in other cells.
In my case of cells in a higher column AND even cells with a formula!
The solution was to fill the new added row from back to front, so calculations would not go wrong.
Excel normally can deal with formula's in different cells, but it seems adding a row in a table kicks of a recalculation in order of the columns (A,B,C,etc..).
Hope this helps clearing issues with .ListRows.Add
As using ListRow.Add can be a huge bottle neck, we should only use it if it can’t be avoided.
If performance is important to you, use this function here to resize the table, which is quite faster than adding rows the recommended way.
Be aware that this will overwrite data below your table if there is any!
This function is based on the accepted answer of Chris Neilsen
Public Sub AddRowToTable(ByRef tableName As String, ByRef data As Variant)
Dim tableLO As ListObject
Dim tableRange As Range
Dim newRow As Range
Set tableLO = Range(tableName).ListObject
tableLO.AutoFilter.ShowAllData
If (tableLO.ListRows.Count = 0) Then
Set newRow = tableLO.ListRows.Add(AlwaysInsert:=True).Range
Else
Set tableRange = tableLO.Range
tableLO.Resize tableRange.Resize(tableRange.Rows.Count + 1, tableRange.Columns.Count)
Set newRow = tableLO.ListRows(tableLO.ListRows.Count).Range
End If
If TypeName(data) = "Range" Then
newRow = data.Value
Else
newRow = data
End If
End Sub
Just delete the table and create a new table with a different name. Also Don't delete entire row for that table. It seems when entire row containing table row is delete it damages the DataBodyRange is damaged
I have a little problem, I occasionally bump into this kind of problem, but I haven’t found a fast solution so far.
So, imagine we have an Excel worksheet and let's suppose that we have a couple of numbers in column ’A’ with some empty cells in it. Altogether (just to make it simple) we have the first 10 cells in column 'A' to observe. For example:
3
(empty cell)
(empty cell)
6
(empty cell)
4
(empty cell)
23
(empty cell)
2
Now in the next step I would like to collect these numbers into another column (for example, column ’B’) using VBA. Obviously I just want to collect those cells which contain a number and I want to ignore the empty cells. So I would like to get a column something like this:
3
6
4
23
2
I have already written the following code, but I’m stuck at this point.
Sub collect()
For i = 1 To 10
if cells(i,1)<>"" then...
Next i
End Sub
Is there an easy way to solve this problem?
Probably the quickest and easiest way is to use Excel's Advanced Filter - the only amendment you'll need to make is it add a field name and criteria. You can even list unique items only:
The VBA equivalent is
Sub test()
With Sheet1
.Range("B1:B8").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range( _
"D1:D2"), CopyToRange:=.Range("F1"), Unique:=False
End With
End Sub
You should be able to use the method in the post int the comments, but you could also use SpecialCells like Range("A:A").SpecialCells(xlCellTypeConstants,xlNumbers).Copy to get all of the filled cells.
Edit: needed constants not formulas.
This will work for any number of rows that you select. It will always output in the next column at the start of your selection e.g. if data starts in B10 it will ooutput in C10
Sub RemoveBlanks()
Dim cl As Range, cnt As Long
cnt = 0
For Each cl In Selection
If Not cl = vbNullString Then
Cells(Selection.Cells(1, 1).Row, Selection.Cells(1, 1).Column).Offset(cnt, 1) = cl
cnt = cnt + 1
End If
Next cl
End Sub
If you wish to loop manually and don't mind specifying the maximum row limit;
Dim i As long, values As long
For i = 1 To 10
If cells(i, 1).Value <> "" Then
values = (values + 1)
' // Adjacent column target
cells(values, 2).value = cells(i, 1).value
End If
Next i