I have an unsorted list of names in Sheet1, Column A. Many of these names appear more than once in the list.
On Sheet2 Column A I want an alphabetically sorted list of the names with no duplicate values.
What is the optimal method of achieving this using VBA?
Methods I have seen so far include:
Making a collection with CStr(name) as the key, looping through the range and trying to add each name; if there is an error it is not unique, ignore it, else expand the range by 1 cell and add the name
Same as (1), except ignore about the errors. When the loop is complete, only unique values will be in the collection: THEN add the whole collection to the range
Using the match worksheet function on the range: if no match, expand the range by one cell and add the name
Maybe some simulation of the "remove duplicates" button on the data tab? (haven't looked into this)
I really like the dictionary object in VBA. It's not natively available but it's very capable. You need to add a reference to Microsoft Scripting Runtime then you can do something like this:
Dim dic As Dictionary
Set dic = New Dictionary
Dim srcRng As Range
Dim lastRow As Integer
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Cells(1, 1).End(xlDown).Row
Set srcRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))
Dim cell As Range
For Each cell In srcRng
If Not dic.Exists(cell.Value) Then
dic.Add cell.Value, cell.Value 'key, value
End If
Next cell
Set ws = Sheets("Sheet2")
Dim destRow As Integer
destRow = 1
Dim entry As Variant
'the Transpose function is essential otherwise the first key is repeated in the vertically oriented range
ws.Range(ws.Cells(destRow, 1), ws.Cells(dic.Count, 1)) = Application.Transpose(dic.Items)
As you suggested, a dictionary of some sort is the key. I would use a Collection - it is builtin (in contrary to Scripting.Dictionary) and does the job.
If by "optimal" you mean "fast", the second trick is to not access each cell individually. Instead use a buffer. The below code will be fast even with thousands of rows of input.
Code:
' src is the range to scan. It must be a single rectangular range (no multiselect).
' dst gives the offset where to paste. Should be a single cell.
' Pasted values will have shape N rows x 1 column, with unknown N.
' src and dst can be in different Worksheets or Workbooks.
Public Sub unique(src As Range, dst As Range)
Dim cl As Collection
Dim buf_in() As Variant
Dim buf_out() As Variant
Dim val As Variant
Dim i As Long
' It is good practice to catch special cases.
If src.Cells.Count = 1 Then
dst.Value = src.Value ' ...which is not an array for a single cell
Exit Sub
End If
' read all values at once
buf_in = src.Value
Set cl = New Collection
' Skip all already-present or invalid values
On Error Resume Next
For Each val In buf_in
cl.Add val, CStr(val)
Next
On Error GoTo 0
' transfer into output buffer
ReDim buf_out(1 To cl.Count, 1 To 1)
For i = 1 To cl.Count
buf_out(i, 1) = cl(i)
Next
' write all values at once
dst.Resize(cl.Count, 1).Value = buf_out
End Sub
Related
I'm trying to fill blank cells in a certain region with 0. The reagion should be defined in the current workbook but in sheet2 (not the current sheet). Also the place where it is supposed to fill is between columns
BU:CQ in the current region (not all 100 000 000 lines). Just the number of lines that define the table between columns BU and CQ. I know the problem lies in defining the region... See the code below.
What is missing?
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
InputValue = "0"
For Each cell In ThisWorkbook.Sheets("Sheet2").Range(BU).CurrentRegion
'.Cells(Rows.Count, 2).End(xlUp).Row
If IsEmpty(cell) Then
cell.Value = InputValue
End If
Next
End Sub
I've this code that i'm positive that works! But i don't wnat selection! I want somthing that specifies the sheet and a fixed range.
Now my idea is to replace "selection" with the desired range. - In this case in particular the range should be 1 - between BU:CQ; 2 - starting at row 2; 3 - working the way down until last row (not empty = end of the table that goes from column A to DE)
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = "0"
End If
Next
End Sub'
PS: And I also need to specify the sheet, since the button that will execute the code will be in the same workbook but not in the same sheet.
Use SpecialsCells:
On Error Resume Next 'for the case the range would be all filled
With ws
Intersect(.UsedRange, .Range("BU:CQ")).SpecialCells(xlCellTypeBlanks).Value = 0
End With
On Error GoTo 0
MUCH faster than looping !
Try using cells() references, such as:
For i = cells(1,"BU").Column to cells(1,"CQ").Column
cells(1,i).value = "Moo"
Next i
In your current code you list Range(BU) which is not appropriate syntax. Note that Range() can be used for named ranges, e.g., Range("TheseCells"), but the actual cell references are written as Range("A1"), etc. For Cell(), you would use Cells(row,col).
Edit1
With if statement, with second loop:
Dim i as long, j as long, lr as long
lr = cells(rows.count,1).end(xlup).row
For i = 2 to lr 'assumes headers in row 1
For j = cells(1,"BU").Column to cells(1,"CQ").Column
If cells(i,j).value = "" then cells(i,j).value = "Moo"
Next j
Next i
First off, you should reference the worksheet you're working with using:
Set ws = Excel.Application.ThisWorkbook.Worksheets(MyWorksheetName)
Otherwise VBA is going to choose the worksheet for you, and it may or may not be the worksheet you want to work with.
And then use it to specify ranges on specific worksheets such as ws.Range or ws.Cells. This is a much better method for specifying which worksheet you're working on.
Now for your question:
I would reference the range using the following syntax:
Dim MyRange As Range
Set MyRange = ws.Range("BU:CQ")
I would iterate through the range like so:
Edit: I tested this and it works. Obviously you will want to change the range and worksheet reference; I assume you're competent enough to do this yourself. I didn't make a variable for my worksheet because another way to reference a worksheet is to use the worksheet's (Name) property in the property window, which you can set to whatever you want; this is a free, global variable.
Where I defined testWS in the properties window:
Public Sub test()
Dim MyRange As Range
Dim tblHeight As Long
Dim tblLength As Long
Dim offsetLen As Long
Dim i As Long
Dim j As Long
With testWS
'set this this to your "BU:CQ" range
Set MyRange = .Range("P:W")
'set this to "A:BU" to get the offset from A to BU
offsetLen = .Range("A:P").Columns.Count - 1
'set this to your "A" range
tblHeight = .Range("P" & .Rows.Count).End(xlUp).Row
tblLength = MyRange.Columns.Count
End With
'iterate through the number of rows
For i = 1 To tblHeight
'iterate through the number of columns
For j = 1 To tblLength
If IsEmpty(testWS.Cells(i, offsetLen + j).Value) Then
testWS.Cells(i, offsetLen + j).Value = 0
End If
Next
Next
End Sub
Before:
After (I stopped it early, so it didn't go through all the rows in the file):
If there's a better way to do this, then let me know.
Assume that this is my data in Excel Data containing duplicate values in the first three columns.
As you can see the values in the first three columns are repeated for a number of rows.
I want to remove the duplicate values in them just like this screenshot
duplicate values are removed using a macro
I decided to use a macro that does this for me automatically and I found this VBS code that removes the duplicate values. What the macro actually does is that it removes the repeating values in the selected area where the cursor is in, so each time the macro runs I have to select the area that I would like the values to be removed. But, what I want is to remove the duplicates from the columns A, B, and C whether or not they are selected and no matter how many rows there are. And, I want it to work on open automatically.
I considered using Range() instead of Selection() e.g. I put something like Set r = Columns("A:C").Select but that didn't work. Is there a way to do this in VBS?
Option Explicit
Private originalValues()
Private originalRange As String
Sub removeDupes()
Dim r As Range 'target range
Dim arr() 'array to hold values
Dim i As Long, j As Long, k As Long 'loop control
Dim upper1D As Long, upper2D As Long, lower2D As Long 'array bounds
Dim s As String 'temp string to compare values
Set r = Selection.Resize(Cells.SpecialCells(xlLastCell).Row)
If r.Rows.Count = 1 Then Exit Sub 'if the target range is only 1 row then quit
arr = r.Value 'copy the values in r to the array
'store the values for an undo
originalValues = r.Value
originalRange = r.Address
upper1D = UBound(arr) 'get the upper bound of the array's 1st dimension
upper2D = UBound(arr, 2) 'get the upper bound of the array's 2nd dimension
lower2D = LBound(arr, 2) 'get the lower bound of the array's 2nd dimension
'loop through 'rows' in the array
For i = LBound(arr) To upper1D
'loop through all the 'columns' in the current row
For j = lower2D To upper2D
s = arr(i, j) 'record the current array component value in s
'Check to see if duplicates exists in the target range
If Application.CountIf(r.Columns(j), s) > 1 _
And LenB(s) Then
'Duplicate found: if the end of the array has not ye been reached then
'loop through the remaining rows for this column, clearing duplicates
If i < upper1D Then
For k = i + 1 To upper1D
If arr(k, j) = s Then arr(k, j) = ""
Next k
End If
End If
Next j
Next i
'copy array back to target range
r.Value = arr
Application.OnUndo "Undo remove duplicates", "restoreOriginalValues"
End Sub
Private Sub restoreOriginalValues()
Range(originalRange).Value = originalValues
End Sub
Thanks,
Laleh
you have to hardcode the range, like :
with Worksheets("MySheet") '<~~ change the worksheet name as per your actual one
Set r = .Range("A2:C2", .Cells(.Rows.Count, "A").End(xlUp)) '<~~ assuming data are beginning from row 2, otherwise simply change row reference
end with
please consider it's always much safer to explicitly reference the Worksheet name in any Range
this should specially apply to restoreOriginalValues() sub since:
Address property of Range object would store the "pure" range cells address without any sheet reference
restoreOriginalValues could be possibly called after some "sheet-jumping"
so that you'd better define a module scoped Worksheet variable and then use it
Private originalValues()
Private originalRange As String
Private mySht As Worksheet '< ~~ set module scoped `Worksheet` variable
Sub removeDupes()
'... code
originalRange = dataRng.Address '<~~ store the "pure" range cells address without any sheet reference
'... code
End Sub
Private Sub restoreOriginalValues()
mySht.Range(originalRange).Value = originalValues '< ~~ combine module scoped `Worksheet` and `originalRange` variables
End Sub
here follows an alternative approach looping through cells instead of using arrays. it's just for reference since arrays are surely faster where lots of data are concerned
Option Explicit
Private originalValues()
Private originalRange As String
Private mySht As Worksheet
Sub removeDupes()
Dim cell As Range, compCell As Range
Dim headerRng As Range, dataRng As Range
Set mySht = Worksheets("MyData")
With mySht '<~~ change the worksheet name as per your actual one
Set headerRng = .Range("A2:C2") '<~~ change the header columns reference as per your needs
Set dataRng = Range(headerRng.Offset(1), .Cells(.Rows.Count, headerRng.Columns(1).Column).End(xlUp)) '<~~ set data range from row below headers to the row with last non empty cell in first header column
'store the values for an undo
originalValues = dataRng.Value
originalRange = dataRng.Address
For Each cell In dataRng '<~~ loop through every cell
Set compCell = IIf(IsEmpty(cell.Offset(-1)), cell.End(xlUp), cell.Offset(-1)) '<~~ set the cell whose value is to compare the current cell value to
If cell.Value = compCell.Value Then cell.ClearContents '<~~ clear current cell only if its value is the same of its "comparing" cell one
Next cell
End With
restoreOriginalValues
End Sub
Private Sub restoreOriginalValues()
mySht.Range(originalRange).Value = originalValues
End Sub
I've been stuck on this for a while, I could really use some help. I have this sub that searches for a column with the heading "Account" within five worksheets (B,E,L,I,T). When it finds a match, it then does a vlookup to bring the values of that entire column into another sheet in the spread (MasterTab). It works great. But I need to make it a loop so that it can do this process with an array of 550 variables (these are other column headings).
I am very new to loops and understand basic examples but this one seems complex because
I (think I) need to do a loop within a loop, because I have to loop for every mf_x_TEXT variable (the string for my match function), and also every mf_x variable (the match function itself). And since the code itself is a loop, that's three loops.
The mf_x variables rely on the mf_x_TEXT variables to work, so I don't really know how to set it up so that the loop correctly places the right TEXT variable into the right mf_x match function.
Here's my sub that works, without any attempts at getting what I'm talking about to work. If I show you my attempts at doing the loops it will just make things even more confusing. The mf_Account and mf_Account_TEXT is one example of the two sets of 550+ variables.
Sub GetInfoAltVersion()
'
Dim wsMaster As Worksheet: Set wsMaster = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("MasterTab")
Dim vWSs As Variant: vWSs = Array("B", "E", "L", "I", "T")
'
Dim v As Long
Dim Mrange As Range
Dim Vrange As Range
'
With Workbooks("LBImportMacroTemplate.xlsm")
Set Mrange = Nothing
Set Vrange = Nothing
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastrow
End With
'
Dim mf_Account_TEXT As String: mf_Account_TEXT = "Account"
'ETC, THERE ARE MANY MORE VARIABLES JUST LIKE THIS, BUT WITH DIFFERENT STRINGS
'
'THIS IS THE PART THAT I NEED TO LOOP FOR EACH VARIABLE
For v = LBound(vWSs) To UBound(vWSs)
If CBool(Application.CountIf(.Sheets(vWSs(v)).Range("A2:ZA2"), mf_Account_TEXT)) Then
Set Mrange = .Sheets(vWSs(v)).Range("A2:ZA2")
Set Vrange = .Sheets(vWSs(v)).Range("A:ZA")
mf_Account = Application.Match(mf_Account_TEXT, Mrange, 0)
'
For i = 2 To lastrow
wsMaster.Cells(i, 2) = Application.VLookup(wsMaster.Cells(i, 1), Vrange, mf_Account, 0)
Next i
Exit For
End If
Next v
Set Mrange = Nothing
Set Vrange = Nothing
'
End With
End Sub
One thing that could help is if I could put the application.Match function inside the vlookup function without having to make it a variable, because that would eliminate one of the needed loops. But I couldn't get the vlookup to work this way. The only way I was able to do it was do declare the match function as a variable, and then put the variable in the index_col_num section of the vlookup.
I know a programmer wouldn't write this manually 550 times, so there must be a way that is beyond my current understanding. Please help if you can, it is driving me nuts.
This will get the "variable" names from the Master Sheet. Put them all in row 1 starting in column 2. It is assumed that the value to look up in the other sheets is in the first column in both the Master Sheet and the other sheets.
If the lookup value and the column are in multiple sheets, then this will overwrite the value with the sheet listed later in your array. For instance, if lookup value "12345" and column Name "Account" are in both worksheet "B" and worksheet "T", then the value in worksheet "T" will be the one that shows up in your data. If you need a value from a different worksheet, then reorder the array to put the most important sheet last or the code will need to be modified.
Note that this is likely not the most efficient way to do this, but it should work.
Sub GetInfoAltVersion()
Dim xlWb As Workbook
Dim wsMaster As Worksheet
Dim vWSs As Variant: vWSs = Array("B", "E", "L", "I", "T")
Dim v As Long
Dim Mrange As Range
Dim Vrange As Range
Dim colName As String
Dim lastCol As Integer
Dim LastRow As Long
Dim AccountCol As Integer
Dim CurrSheet As Worksheet
Set xlWb = Workbooks("LBImportMacroTemplate.xlsm")
Set wsMaster = xlWb.Worksheets("MasterTab")
LastRow = wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row
MsgBox LastRow
lastCol = wsMaster.Cells(1, wsMaster.Columns.Count).End(xlToLeft).Column
MsgBox lastCol
For j = 2 To lastCol
colName = wsMaster.Cells(1, j).Value
For v = LBound(vWSs) To UBound(vWSs)
CurrSheet = xlWb.Sheets(vWSs(v))
If CBool(Application.CountIf(CurrSheet.Range("A2:ZA2"), colName)) Then
Set Mrange = CurrSheet.Range("A2:ZA2")
Set Vrange = CurrSheet.Range("A:ZA")
AccountCol = Application.Match(j, Mrange, 0)
'
For i = 2 To LastRow
wsMaster.Cells(i, j) = Application.VLookup(wsMaster.Cells(i, 1), Vrange, AccountCol, 0)
Next i
End If
Next v
Set Mrange = Nothing
Set Vrange = Nothing
'
Next j
End Sub
Hope this helps.
While I can't authoritatively answer VBA-specific questions, I can provide a general programming suggestion.
If the values you want to iterate through are already in your worksheets, you could collect the values from the worksheets. If not, you could create another worksheet to store the list of values.
If for some reason you can't externalize the data, you can simply create a single variable (or constant) to store the values in a collection. Depending on your use case, you can use a list (sequential) or map (key-value pairs) type to store them. This would enable you to iterate over the list or the set of keys, respectively.
I want to find all the cells in Column L with a particular value and return the values in Column D of the same row as those cells found.
So far, I am only able to return one result, which would be the top most result in my list, but I want to find all the rest as well, which I don't know the code to use.
Just to further explain: Value in cell D11 is the value I want to find in Column L of sheet "Master List". Supposedly I find the value in cells L13, L15 and L20, I want to return the value in cell D13, D15 and D20 into cells "C37:C39" of ws. Note: no. of cells that have the value may vary so the values returned will just appear from C37 downwards (something like automatic multiple selection, copy and paste)
Here's a little something to start the ball rolling:
Sub FindRelatedProducts()
Dim cell As Excel.Range
Dim D11Value As Variant
Dim D11Row As Variant
Dim ws As Worksheet: Set ws = Sheets("RShip")
Set cell = ws.Range("D11")
D11Value = cell.Value
With Sheets("Master List")
D11Row = Application.Match(D11Value, .Range("L:L"), 0)
If Not IsError(D11Row) Then
ws.Range("C37") = .Range("D" & D11Row).Value
End If
End With
End Sub
Here's an example using range variables.
You'll want to define a range for the input data range and a range for the output data. Then in the VBA you will want to change the wrk, inRng and outRng variables to be the named ranges you defined and change the column indexes in the for and if blocks to match the column index of the data you are looking for.
Option Explicit
Option Base 1
Sub FindValues()
Dim wrk As Worksheet
Dim inRng As Range
Dim outRng As Range
Dim cntr As Long
Dim outCntr As Long
Dim findVal As Double
Set wrk = Worksheets("Data")
Set inRng = wrk.Range("LookupRange")
Set outRng = wrk.Range("OutputRange")
' Clear the output range in case you have fewer values on this run than on the previous one
outRng.ClearContents
' Set the value you are looking for
findVal = 1
' Iterate through the rows in the input range. If you find the result you want then write it to the output range
For cntr = 1 To inRng.Rows.Count
If inRng(cntr, 1) = findVal Then ' Assumes the value you are finding is in column 1 of the input range
outRng(outCntr, 1) = inRng(cntr, 2) ' Assumes the values you are exporting is in column 2 of the input range
outCntr = outCntr + 1
End If
Next cntr
End Sub
I'm trying to make a macro in Excel VBA 2007 that searches through the selected field and if it finds a certain string anywhere in a row, it copies and pastes that row into another sheet.
However, I'm getting the error in the title on the row noted below. What would be causing this?
Sub SearchCopyPaste()
'
' SearchCopyPaste Macro
' Searches for a string. If it finds that string in the line of a document then it copies and pastes it into a new worksheet.
'
' Keyboard Shortcut: Ctrl+Shift+W
'
Dim sourceSheet, destinationSheet As Worksheet
Set sourceSheet = Worksheets(1) 'Define worksheets
Set destinationSheet = Worksheets(2)
Dim selectedRange As Range 'Define source range
Set selectedRange = Selection
Dim numRows, numColumns As Integer 'Determine how many rows and columns are to be searched
numRows = Range(selectedRange).Rows.Count '<<<<<<<< Error
numColumns = Range(selectedRange).Columns.Count
destinationRowCount = 1 'Counter to see how many lines have been copied already
'Used to not overwrite, can be modified to add header,etc
Dim searchString As String 'String that will be searched. Will eventually be inputted
searchString = "bccs" 'Will eventually be put into msgbox
For rowNumber = 1 To numRows
If InStr(1, selectedRange.Cells(i, numColumns), searchString) > 0 Then
selectedRange.Cells(rowNumber, numColumns).Copy Destination:=destinationSheet.Range(Cells(destinationRowCount, numColumns))
destinationRowCount = destinationRowCount + 1
End If
Next rowNumber
End Sub
Try:
numRows = selectedRange.Rows.Count '<<<<<<<< Error
numColumns = selectedRange.Columns.Count
There may be other errors, I have not tested your full code, but this should fix the immediate error you're experiencing.
Some tips:
Declare all of your variables at the top of your sub
Add a new line for each variable to make your code more readable
Anytime you are using a variable to store row numbers declare it as Long
If you know the range you want to work with beforehand define it as a range in your code
This code should do something close to what you want. Give it a try and let me know.
If you know the range you would like to use before running the macro instead of using "Selection" I suggest specifying the exact range or "Sheets(1).UsedRange" for the entire first sheet.
Sub SearchCopyPaste()
Dim fnd As String
Dim vCell As Range
Dim rng As Range
Dim totalCols As Integer
Dim rowCounter As Long
'Set this to a specific range if possible
Set rng = Selection
totalCols = rng.Columns.Count
'Get the data to find from the user
fnd = InputBox("Input data to find")
'Loop through all cells in the selected range
For Each vCell In rng
'If the data is found copy the data and paste it to Sheet2, move down one row each time
If InStr(vCell.Value, fnd) > 0 Then
rowCounter = rowCounter + 1
Range(Cells(vCell.row, 1), Cells(vCell.row, totalCols)).Copy Destination:=Sheets(2).Cells(rowCounter, 1)
End If
Next
'Copy the column headers onto the second sheet
Sheets(2).Rows(1).EntireRow.Insert
rng.Range(Cells(1, 1), Cells(1, totalCols)).Copy Destination:=Sheets(2).Cells(1, 1)
End Sub