I have a spreadsheet that includes an ID and a Name. I'd like to have a procedure that (when the user enters a specific ID) will find the most recent instance of that code in the same column, then will check the next column row if its empty. For example:
ID | Name
SD123456 | John
DF989899 | Alice
SD123456 | Jason
KA452331 | Wilson
SD123456 |
DF456790 | Jack
As you can see, the ID 'SD123456' has a missing name, therefore I would like to know if its possible to search for the ID 'SD123456' and get the last row of that ID and check the next column row if its missing. I've tried using xlDown and xlUp but to no avail.
EDIT: In summary, my whole VBA purpose is to search for the ID, then check if that latest ID has a name to it, if not, alert the user that, the ID has a missing name.
You may try this, simple and clear:
Dim lastrow As Long, i As Long
Dim ID As String
lastrow = Sheet1.UsedRange.Rows.Count
ID = "DF989899"
For i = 2 To lastrow
If InStr(Sheet1.Cells(i, 1).Value, ID) And IsEmpty(Sheet1.Cells(i, 2).Value) Then
MsgBox "Missing Value for ID: " & Sheet1.Cells(i, 1).Value
End If
Next
Find the Last Occurrence of a String in a Column
Option Explicit
Sub CheckIDtest()
CheckID "SD123456"
End Sub
Sub CheckID(ByVal ID As String)
' Create references to the ID and Name Column Ranges.
Dim irg As Range, nrg As Range
With Sheet1.Range("A1").CurrentRegion
Set irg = .Columns(1)
Set nrg = .Columns(2)
End With
' Attempt to find the last occurrence of the ID.
Dim fCell As Range
Set fCell = irg.Find(ID, , xlFormulas, xlWhole, , xlPrevious)
' ID was not found.
If fCell Is Nothing Then
MsgBox "The ID '" & ID & "' was not found.", _
vbCritical, "ID Not Found"
Exit Sub
End If
' Write the associated name to a variable.
' This complication allows for the columns not to be adjacent.
Dim fName As String: fName = fCell.EntireRow.Columns(nrg.Column).Value
' If they are adjacent like in this case, you could simplify with...
'fName = fCell.Offset(, 1).Value
' ... and forget about 'nrg'.
If Len(fName) = 0 Then
MsgBox "The Name for the ID '" & ID & "' is missing.", _
vbExclamation, "Missing Name"
Else
MsgBox "The Name for the ID '" & ID & "' is '" & fName & "'.", _
vbInformation, "Name Found"
End If
End Sub
Related
I have searched quite a bit for this but keep finding where people want to copy to another sheet and that's not what I want. I want to just duplicate a column labeled "Student ID" since it isn't always in column D and to reference the Active Sheet since the sheet isn't always named Sheet1. The additional code then adds a 0 to the end of the data in the new duplicated column and labels the new column "Patron". I am fairly new to VBA so struggling with this.
Range("D:D").Copy
Range("E:E").Insert
Range("E1").Value = "PATRON"
Range("IV1") = 10
Range("IV1").Copy
Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues, xlPasteSpecialOperationMultiply
Range("IV1").Delete xlShiftUp
End Sub
Something like the following could work:
Option Explicit
Public Sub Example()
DuplicateColumn ThisWorkbook.ActiveSheet, "Student ID", "PATRON"
End Sub
Public Sub DuplicateColumn(ByVal ws As Worksheet, ByVal HeaderName As String, ByVal NewColumnName As String)
' find the header name
Dim ColumnFound As Range
Set ColumnFound = ws.Rows(1).Find(What:=HeaderName, _
After:=ws.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
' check if it was found
If ColumnFound Is Nothing Then
MsgBox "Column '" & HeaderName & "' was not found.", vbCritical
Exit Sub
End If
' copy that column
With ColumnFound.EntireColumn
.Copy
.Offset(ColumnOffset:=1).Insert
End With
' give the new column a new name
ColumnFound.Offset(ColumnOffset:=1).Value = NewColumnName
' add 0 at the end of that column
ws.Cells(ws.Rows.Count, ColumnFound.Column + 1).End(xlUp).Offset(RowOffset:=1).Value = 0
End Sub
This code finds the column labeled "Student ID" and inserts a new column then copies the data to the new column. Since I'm not sure about what the rest of the code does, I'll leave that to you. Also, to a a zero at the endd of a cell 's data, just do something like cells(row, Col+1).value = cells(row, Col+1).value & "0"
Set sht = ActiveSheet 'set variable to active sheet
' Finds the column NUMBER for Student ID
Col = sht.Rows(1).Find(What:="Student ID", LookIn:=xlValues, LookAt:=xlWhole).Column
Columns(Col + 1).Insert 'insert new column
Columns(Col).Copy Columns(Col + 1) 'copy Student ID column data to new column
Cells(1, Col + 1).Value = "PATRON" 'add header to new column
Use Find to locate header and Concatenate to add the zero.
Option Explicit
Sub macro1()
Const COL_NAME = "Student ID"
Dim ws As Worksheet, rng As Range
Dim r As Long, c As Long, LastRow As Long
Set ws = ActiveSheet
Set rng = ws.Cells.Find(COL_NAME, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
MsgBox "Could not locate column '" & COL_NAME & "'", vbCritical
Exit Sub
Else
r = rng.Row
c = rng.Column
LastRow = ws.Cells(Rows.Count, c).End(xlUp).Row
ws.Columns(c + 1).Insert
ws.Cells(r, c + 1) = "PATRON"
Set rng = ws.Cells(r + 1, c + 1).Resize(LastRow - r)
rng.FormulaR1C1 = "=CONCATENATE(RC[-1],0)"
'rng.Value2 = rng.Value2 'uncomment if you want values not fomulae
End If
End Sub
I am attempting to create an Excel sheet based on an already existing workbook. I can't change the format of the workbook, so I am stuck with what follows.
We are creating a system to use a hand scanner with barcodes containing staff names, for the purposes of tracking COVID testing.
Our workbook has one column for first name, one for last.
So B2 = Cluff, C2 = Aaron
How do I use an input box (for the scanner) that searches the string "Cluff, Aaron" (user input in the box, not the name specifically in the code) and returns the row with the data above?
Bonus points if it opens a new input box to enter the test UPC (another input looking for a string), and inputs into Column AA on the same row.
My knowledge of VBA is very limited.
I tried various edits to the following code:
Sub DualFind()
Dim vFind1 As String, vFind2 As String
Dim rFound As Range, lLoop As Long
Dim bFound As Boolean
Dim rLookIn1 As Range, rLookIn2 As Range
vFind1 = InputBox("Find What: First value?", "FIND FIRST VALUE")
If vFind1 = vbNullString Then Exit Sub
vFind2 = InputBox("Find What: Second value?", "FIND SECOND VALUE")
If vFind2 = vbNullString Then Exit Sub
If Selection.Areas.Count > 1 Then
Set rLookIn1 = Selection.Areas(1).Columns(1)
Set rLookIn2 = Selection.Areas(2).Columns(1)
Else
Set rLookIn1 = Selection.Columns(1)
Set rLookIn2 = Selection.Columns(2)
End If
Set rFound = rLookIn1.Cells(1, 1)
For lLoop = 1 To WorksheetFunction.CountIf(rLookIn1, vFind1)
Set rFound = rLookIn1.Find(What:=vFind1, After:=rFound, LookAt:=xlWhole)
If UCase(rLookIn2.Cells(rFound.Row, 1)) = UCase(vFind2) Then
bFound = True
Exit For
End If
Next lLoop
If bFound = True Then
MsgBox "Match found", vbInformation, "ozgrid.com"
Range(rFound, rLookIn2.Cells(rFound.Row, 1)).Select
Else
MsgBox "Sorry, no match found", vbInformation, "ozgrid.com"
End If
End Sub
From what I gather, it needs two separate inputs to search the columns. I need it to search two columns with one input. I imagine you'd have to compile columns B and C into a string, and then search it based on input from the box.
Not entirely sure if this is what you were after but hopefully it will at least give you some more ideas. I've written this so that the user inputs the search name in the format [first name] [last name], e.g. Aaron Cluff. I've assumed from what you've written that the last name is found in column 2 and the first name in column 3.
Sub Demo()
Dim SearchName As String
Dim UPC As String
Dim LastRow As Long
Dim Row As Long
Dim RowMatch As Long
Dim ColFirstName As Integer
Dim ColLastName As Integer
ColLastName = 2
ColFirstName = 3
SearchName = InputBox("Enter search name: e.g. Aaron Cuff", "Search")
If SearchName = "" Then Exit Sub
SearchName = Trim(SearchName)
LastRow = Cells(Rows.Count, ColLastName).End(xlUp).Row
For Row = 1 To LastRow
If StrComp(SearchName, Trim(Cells(Row, ColFirstName)) & " " & Trim(Cells(Row, ColLastName)), vbTextCompare) = 0 Then
RowMatch = Row
Exit For
End If
Next
If RowMatch = 0 Then
MsgBox "Search Name: " & StrConv(SearchName, vbProperCase) & vbNewLine & vbNewLine & _
"No Match Found", vbInformation, "Search Result"
Exit Sub
End If
UPC = InputBox("Enter Test UPC for " & StrConv(SearchName, vbProperCase) & ": ", "Input")
If UPC <> "" Then
Cells(RowMatch, "AA") = UPC
End If
End Sub
Here's one way to do the staff name lookup:
Dim ws As Worksheet
Dim rng As Range, m, staffName
Set ws = Worksheets("Staff")
staffName = "Cluff, Aaron"
m = ws.Evaluate("MATCH(""" & staffName & """,A1:A1000 & "", "" &B1:B1000,0)")
If Not IsError(m) Then
Debug.Print "Matched on row " & m
Else
Debug.Print "No match for " & staffName
End If
I am using Excel 2010.
I have some VBA code which creates a unique key and then looks for duplicate unique key entries. Any duplicates are coloured in red.
I need to automate this a little further. If there is a duplicate unique key, copy the information from the newest entry, and paste it into the line where the original entry is. I then want the newest entry deleted.
The unique key is a concat of the customer name and the date the file was created. There will only ever be at most one duplicate entry per customer and that will be because the date the file was last updated has changed. I need the duplicate concat entry with the newest date to copy the info over the top of the entry with the oldest date on it then delete the original newest date entry. This is because we have other checks that have been completed further along the sheet that we need to keep intact.
Ideally I would like for the message box to still advise how many duplicate entries were found and for the entry to remain coloured red once the copy/paste/delete has taken place to highlight the entry that has been changed.
Private Sub CommandButton1_Click()
'Start of Concatenate Code
Dim i As Integer
Dim r As Range
On Error Resume Next
' Tells Excel to look in column 3 (Column C) for the last one with data in it
lRow = Cells(Rows.Count, 3).End(xlUp).Row
' Tell Excel to focus on cells 4 to 5000
For i = 4 To lRow
' Tell Excel to paste the contents of cell 4 (column D) followed by |
' then the contents of cell 8 (column H) into cell 2 (column B)
Cells(i, 2).Value = Cells(i, 11) & " | " & Cells(i, 7)
Next i
'End of Concatenate Code
'Start of Check for Duplicates code
Dim j As Integer
Dim myCell As Range
Dim myRange As Integer
myRange = Range("A4:A5000").Count
j = 0
' Select the Range
For Each myCell In Range("B4:B5000")
' Check that the cells in the range are not blank
If WorksheetFunction.CountIf(Range("B4:B5000"), myCell.Value) > 1 Then
' Colour the duplicate entries in red
myCell.EntireRow.Interior.ColorIndex = 3
j = j + 1
End If
Next
MsgBox "There are " & j & " duplicates found." & vbCrLf & vbCrLf & _
"Any duplicates have been highlighted in red.", vbInformation + vbOKOnly, _
"Duplicate Entry Checker"
' End of Check for Duplicates code
End Sub
Screenshot of spreadsheet
Thank you #rickmanalexander, I just tried your code (and changed the name of the sheet) but I get a subscript out of range error with the number 9 in the msgbox title. There must be something i have missed but i am not sure what?
Here is the code I used:
Private Sub CommandButton1_Click()
On Error GoTo CleanFail
Dim wrkSht As Worksheet
Set wrkSht = Sheets("Raw Data")
Dim lRow As Long
lRow = wrkSht.Cells(wrkSht.Rows.Count, 3).End(xlUp).Row
Dim arrySheet As Variant
'get the worksheet data into an array
arrySheet = wrkSht.Range("D1:H" & lRow).Value2
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim keyValue As Variant
Dim i As Long
Dim rowNum As Long
Dim dupCount As Long
For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)
'a concatenated key consisting of the:
'row number
'customer's name
keyValue = Join(Array(i, arrySheet(i, 1)), "|")
If Not dict.Exists(keyValue) Then
dict(keyValue) = arrySheet(i, 8) 'save the date for this unique key
Else
'if we make it here, then this is a duplicate customer
'for which we want to check the date
'If the current row's date is greater than the previouly saved date, then
'delete the current row
'determine the row umber for the previously saved entry
'place the most recent date in place of the old date
'color it red
'increase the duplicate counter
If arrySheet(i, 8) > dict(keyValue) Then
wrkSht.Rows(i).EntireRow.Delete
rowNum = CLng(Split(keyValue, "|")(0))
wrkSht.Cells(rowNum, "B").Value = CDate(arrySheet(i, 8))
wrkSht.Rows(rowNum).EntireRow.Interior.ColorIndex = 3
dupCount = dupCount = dupCount + 1
End If
End If
'clear variables
keyValue = vbNullString: rowNum = 0
Next i
MsgBox "There were " & dupCount & " duplicates found." & _
vbCrLf & vbCrLf & _
"Any duplicates have been highlighted in red.", _
vbInformation + vbOKOnly, "Duplicate Entry Checker"
CleanExit:
Exit Sub
CleanFail:
MsgBox Err.Description, vbCritical, Err.Number
Resume CleanExit
End Sub
Edit:
OP was getting Error 9 subscript out of range, because I used arrySheet(i, 8) instead of arrySheet(i, 4). I was thinking that I defined the array from the range starting at column A. Simple mistake with an easy fix.
The Dictionary Object is the perfect candidate for duplicate checks, so that is what I went with. The code below is untested, but should work for your needs.
Option Explicit
Private Sub CommandButton1_Click()
On Error GoTo CleanFail
Dim wrkSht As Worksheet
Set wrkSht = Sheets("Raw Data")
Dim lRow As Long
lRow = wrkSht.Cells(wrkSht.Rows.Count, 3).End(xlUp).Row
Dim arrySheet As Variant
'get the worksheet data into an array
arrySheet = wrkSht.Range("D1:H" & lRow).Value2
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim keyValue As Variant
Dim i As Long
Dim rowNum As Long
Dim dupCount As Long
For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)
'a concatenated key consisting of the:
'row number
'customer's name
keyValue = Join(Array(i, arrySheet(i, 1)), "|")
If Not dict.Exists(keyValue) Then
dict(keyValue) = arrySheet(i, 4) 'save the date for this unique key
Else
'if we make it here, then this is a duplicate customer
'for which we want to check the date
'If the current row's date is greater than the previouly saved date, then
'delete the current row
'determine the row umber for the previously saved entry
'place the most recent date in place of the old date
'color it red
'increase the duplicate counter
If arrySheet(i,4) > dict(keyValue) Then
wrkSht.Rows(i).EntireRow.Delete
rowNum = CLng(Split(keyValue, "|")(0))
wrkSht.Cells(rowNum, "B").Value = CDate(arrySheet(i, 4))
wrkSht.Rows(rowNum).EntireRow.Interior.ColorIndex = 3
dupCount = dupCount = dupCount + 1
End If
End If
'clear variables
keyValue = vbNullString: rowNum = 0
Next i
MsgBox "There were " & dupCount & " duplicates found." & _
vbCrLf & vbCrLf & _
"Any duplicates have been highlighted in red.", _
vbInformation + vbOKOnly, "Duplicate Entry Checker"
CleanExit:
Exit Sub
CleanFail:
MsgBox Err.Description, vbCritical, Err.Number
Resume CleanExit
End Sub
I have this code and it only works if the header I'm looking for is in column B or "higher".
Lets say I have this table and need to find what column "Name" and "score" is in.
Name score
John 1
Joe 5
If "Name" is in B1 and "score" is in C1 the following code will work:
NameColumn = Split(Cells(1, Cells(1, 1).EntireRow.Find(What:="Name", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True).Column).Address(True, False), "$")(0)
ScoreColumn = Split(Cells(1, Cells(1, 1).EntireRow.Find(What:="score", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True).Column).Address(True, False), "$")(0)
^^ <- search value
The above code would in the case return
NameColumn = "B"
ScoreColumn = "C"
But suppose the columns are A & B then it will not find "Name" because it starts searching after cell 1,1 (A1) which is where the header is.
What can I change to make this work, or what alternatives are there to returning "A" and "B" in the example above?
Here is a quick UDF function that i have used in the past.
This may not be the best way to do it, but this is one I have used for many years.
Function ColumnHeaderLocation(entry As String, Optional ColumnNumber As Boolean)
Dim x, y As Long
y = ActiveSheet.Columns.Count
x = 1
Do Until x > y
If ActiveSheet.Cells(1, x).Value = entry Then
ColumnHeaderLocation = Split(ActiveSheet.Cells(1, x).Address(True, False), "$")(0)
If ColumnNumber = True Then ColumnHeaderLocation = x
Exit Function
Else
x = x + 1
End If
Loop
End Function
Simply use the name of the column header (see example)...
NameColumn = ColumnHeaderLocation("Name") ' returns Column Location as a letter
Or
NameColumn = ColumnHeaderLocation("Name", True) ' Returns column Location as a Number
Header Column Letter Calculation
You will have to add the After argument to the Find method pointing to the last cell .Cells(.Cells.Count) to start the search from the first cell .Cells(1). But as chris neilsen in the comments pointed out, this is not the reason your code would fail, because it would find Name at the end of the search.
Since you haven't defined what 'not working' actually means, and it is highly unlikely that you have misspelled Name in A1, I would assume that NameColumn returns an undesired result (<>A) meaning that you have used Name somewhere else in the first row and you really need to start the search from the first cell .Cells(1).
Short Version
Sub FindAfterShort()
Dim NameColumn As String ' Name Column Letter
Dim ScoreColumn As String ' Score Column Letter
With Rows(1)
NameColumn = Split(.Find("Name", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
ScoreColumn = Split(.Find("Score", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
End With
Debug.Print "Column Letters '" & NameColumn & "' and '" & ScoreColumn & "'."
End Sub
Preferable Version
Sub FindAfterPref()
Const cSheet As String = "Sheet1" ' Worksheet Name
Dim strName As String ' Name Column Letter
Dim strScore As String ' Score Column Letter
With ThisWorkbook.Worksheets(cSheet).Rows(1)
strName = Split(.Find("Name", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
strScore = Split(.Find("Score", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
End With
Debug.Print "Column Letters '" & strName & "' and '" & strScore & "'."
End Sub
A Small Study
Sub FindAfter()
Const cSheet As String = "Sheet1" ' Worksheet Name
Const cFR As Long = 2 ' First Row
' The column where the Last Row Number will be calculated.
Const cLRColumn As Variant = "A" ' Last-Row Column Letter/Number
Dim rngName As Range ' Name Column Range, Name Range
Dim rngScore As Range ' Score Column Range, Score Range
Dim lngName As Long ' Name Column Number
Dim lngScore As Long ' Score Column Number
Dim strName As String ' Name Column Letter
Dim strScore As String ' Score Column Letter
Dim lngLR As Long ' Last Row Number (Calculated in Last-Row Column)
With ThisWorkbook.Worksheets(cSheet).Rows(1)
' Find Method Arguments
' 2. After: If you want to start the search from the first cell, you
' have to set the After parameter to the last cell. If you
' have the matching data in the first cell and you set the
' parameter to the first cell (default), it will still be
' found, but a little later (not mili, but micro seconds
' later) so it could be omitted.
' 5. SearchOrder: Whenever a range is a one-row or a one-column range,
' this argument can be omitted. Since you're searching
' in a one-row range, "xlByRows" would have been the
' more 'correct' way in this case.
' 6. SearchDirection: This argument's parameter is by default "xlNext"
' and can therefore be omitted
' 7. MatchCase: This argument's parameter is by default "False". Since
' I don't see the reason why you would have headers with
' the same name, especially the ones you don't need
' before the ones you need, it is omitted. If you really
' need it, use "... xlWhole, , , True".
Set rngName = .Find("Name", .Cells(.Cells.Count), xlValues, xlWhole)
Set rngScore = .Find("Score", .Cells(.Cells.Count), xlValues, xlWhole)
' Address Arguments
' If the Address arguments are omitted, Range.Address returns the
' address as an absolute reference e.g. $A$1. When you split
' $A$1 you will get the following
' INDEX STRING
' 0 - Empty string ("").
' 1 A - Use this i.e. index 1 for the split array index.
' 2 1
If Not rngName Is Nothing Then ' When "Name" was found.
' Calculate Name Column Number.
lngName = rngName.Column
' Calculate Name Column Letter.
strName = Split(rngName.Address, "$")(1)
End If
If Not rngScore Is Nothing Then ' When "Score" was found.
' Calculate Score Column Number.
lngScore = rngScore.Column
' Calculate Score Column Letter.
strScore = Split(rngScore.Address, "$")(1)
End If
Debug.Print "Column Numbers '" & lngName & "' and '" & lngScore & "'."
Debug.Print "Column Letters '" & strName & "' and '" & strScore & "'."
Debug.Print "Name Column Header Address '" & rngName.Address & "'."
Debug.Print "Score Column Header Address '" & rngScore.Address & "'."
With .Parent ' instead of "ThisWorkbook.Worksheets(cSheet)".
'*******************************************************************
' This should demonstrate a case where you don't need the column
' letter (mostly you don't). You should use ".Cells", ".Range" is
' not an option.
'*******************************************************************
' Column Number (lngName)
' Last Row Number calculated using Cells and lngName.
If lngName <> 0 Then
' Calculate last row in Name Column.
lngLR = .Cells(.Rows.Count, lngName).End(xlUp).Row
' Create a reference to the range from First Row to Last Row in
' Name Column.
Set rngName = .Range(.Cells(cFR, lngName), _
.Cells(lngLR, lngName))
End If
'*******************************************************************
' This is the same as the previous and should demonstrate that
' when you already know the column letter, you have two choices:
' you can use ".Cells" or ".Range".
'*******************************************************************
' Column Letter (strName)
' Last Row Number calculated using Cells and strName.
If strName <> "" Then
' Calculate last row in Name Column.
lngLR = .Cells(.Rows.Count, strName).End(xlUp).Row
' Create a reference to the range First Row to Last Row in
' Name Column.
Set rngName = .Range(.Cells(cFR, strName), _
.Cells(lngLR, strName))
End If
' Last Row Number calculated using Range and strName.
If strName <> "" Then
' Calculate last row in Name Column.
lngLR = .Range(strName & .Rows.Count).End(xlUp).Row
' Create a reference to the range from First Row to Last Row in
' Name Column.
Set rngName = .Range(strName & cFR & ":" & strName & lngLR)
End If
'*******************************************************************
' Since the column letter is more user-friendly, the only use
' I can imagine where you might need it, is to inform the user e.g.
MsgBox "Column '" & strName & "' contains the names and column '" _
& strScore & "' contains the scores.", vbInformation, _
"User Information"
End With
Debug.Print "Last (used) Row in Name Column '" & lngLR & "'."
Debug.Print "Name Range Address '" & rngName.Address & "'."
Debug.Print "Column '" & strName & "' contains the Names and column'" _
& strScore & "' contains the scores."
End With
End Sub
new to VBA so please be gentle.....
I have a script that check for duplicates and inserts a count in a column, this works fine however the sheets are often different so I need to ask the user which column to check for duplicates and which column to insert the count. I've modified the script, but I'm only getting zero's entered into the destination column. I can't see what's going wrong. Any help would be great. Thanks in advance.
Sub LookForDuplicates()
Dim LastRow As Long
Dim column1 As String
'display an input box asking for column
column1 = InputBox( _
"Please enter column to ckeck")
'if no file name chosen, say so and stop
If Len(column1) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
Dim column2 As String
'display an input box asking for column
column2 = InputBox( _
"Please enter column to insert results")
'if no file name chosen, say so and stop
If Len(column2) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
'-------------------------------------------------------
'This is the original version of my script with set columns which works great..... However I need the user to specify the column to checck and also which column the results will be entered.
'LastRow = Range("B" & Rows.Count).End(xlUp).Row
' With Range("E1")
' .FormulaR1C1 = "=COUNTIF(C2,RC[-3])"
' .AutoFill Destination:=Range("E1:E" & LastRow)
' Range("E1").Select
' ActiveCell.FormulaR1C1 = "Duplicates"
'-----------------------------------------------------
LastRow = Range(column1 & Rows.Count).End(xlUp).Row
With Range(column2 & "1")
.FormulaR1C1 = "=COUNTIF(C2,RC[-3])"
.AutoFill Destination:=Range(column2 & "1" & ":" & column2 & LastRow)
Range(column2 & "1").Select
ActiveCell.FormulaR1C1 = "Duplicates"
End With
End Sub
I cannot get this working with the user input variables, apologies if I'm missing something but I can't find any resources on this....
The formula: =COUNTIF($B:$B,B2) works except when in the macro.
I need to add this line to the macro replaced with variables from user input like: =COUNTIF($column1:$column1,column12) but I keep getting syntax errors.
Thanks.
If you are expecting a String/Text value from your input box then you should specify it,
Dim column1 As String
'display an input box asking for column
column1 = InputBox("Please enter column to ckeck", "Range to Check", , , , 2)
Instead of juggling with a String here, why don't you just use the Range object where user can simply click on either full range or one cell in that column you want to check..
Using a range to get the inputbox data: You main issue seems to be setting range to check column in formula.
Option Explicit
Sub LookForDuplicates()
Dim LastRow As Long, StartRow as Long
Dim column1 As Range, column2 As Range
Set column1 = Application.InputBox("Please enter _
column to ckeck", "Range to Check", , , , , , 8)
If column1 Is Nothing Then
MsgBox "No column entered"
Exit Sub
End If
Set column2 = Application.InputBox("Please _
enter column to insert results", _
"Range to Output Results", , , , , , 8)
If column2 Is Nothing Then
MsgBox "No column entered"
Exit Sub
End If
LastRow = Cells(Rows.Count, column1.Column).End(xlUp).Row '--updated here
StartRow = column2.Row '-- here a new code added, assuming that you will have at least one row for column titles
With column2
.FormulaR1C1 = "=COUNTIF(R" & column1.Row _
& "C[-1]:R" & LastRow + 2 & "C[-1],RC[-1])"
.AutoFill Destination:=column2.Resize(LastRow - StartRow, 1)
End With
column2.Offset(-1, 0).FormulaR1C1 = "Duplicates"
End Sub
Output:
Solution if anybody else might find this useful:
The issue was even though column 1 was entered as a Column Reference H for example the COUNTIF function required this as a numeric reference so added an extra variable on the column1 value to the numeric value and modified the formula to suit. All working now:
Dim LastRow As Long
Dim column1 As String
'display an input box asking for column
column1 = InputBox( _
"Please enter column to ckeck")
'if no file name chosen, say so and stop
ColumnNumber = Columns(column1).Column
If Len(column1) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
Dim column2 As String
'display an input box asking for column
column2 = InputBox( _
"Please enter column to insert results")
'if no file name chosen, say so and stop
If Len(column2) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
LastRow = Range(column1 & Rows.Count).End(xlUp).Row
With Range(column2 & "1")
.FormulaR1C1 = "=COUNTIF(C" & ColumnNumber & ",C" & ColumnNumber & ")"
.AutoFill Destination:=Range(column2 & "1" & ":" & column2 & LastRow)
Range(column2 & "1").Select
ActiveCell.FormulaR1C1 = "Duplicates"
End With
End Sub