PDA

View Full Version : VBA / Macro -- Retreiving Unique Records



PianoMan5
10-21-2011, 09:48 AM
I'm a newbie as far as VBA and writing code so most of what I've gotten to work I've gotten thru Google (hey...I'm honest!).


Sub Send_Mail()

FormerValue = ActiveWorkbook.ActiveSheet.Range("A1").Value
'Creating variable to place temporary formula in the cell so after the macro is finished, the cell
'can revert back to original value
ActiveWorkbook.ActiveSheet.Range("A1").Formula = "=SUM(IF(FREQUENCY(B14:B50,B14:B50)>0,1))"
Application.Volatile
'Formula to review all values in provided range and provide number of unique values

If ActiveWorkbook.ActiveSheet.Range("A1").Value >= 3 Then
CMF = "Multiple COFs"
End If

If ActiveWorkbook.ActiveSheet.Range("A1").Value = 1 Then
If ActiveWorkbook.ActiveSheet.Range("B14").Value = "" Then
FirstCOF = ActiveSheet.Range("B14").End(xlDown)
CMF = "COF# " & FirstCOF
Else
FirstCOF = ActiveWorkbook.ActiveSheet.Range("B14").Value
CMF = "COF# " & FirstCOF
End If
'Looking for the first value that is not a blank starting at certain cell
End If

FirstCOF = FirstCOF
If ActiveWorkbook.ActiveSheet.Range("A1").Value = 2 Then
If ActiveWorkbook.ActiveSheet.Range("B15").Value = "" Or ActiveWorkbook.ActiveSheet.Range("B15").Value = FirstCOF Then
SecondCOF = ActiveSheet.Range("B15").End(xlDown)
CMF = "COF#s " & FirstCOF & " , " & SecondCOF
Else
SecondCOF = ActiveWorkbook.ActiveSheet.Range("B15").Value
CMF = "COF#s " & FirstCOF & " , " & SecondCOF
End If
End If

'Sending email along wih attached spreadsheet
ActiveWorkbook.ActiveSheet.Range("A1").Value = FormerValue
Application.Dialogs(xlDialogSendMail).Show arg1:=yourname@email.com, _
arg2:="CMF " & ActiveWorkbook.ActiveSheet.Range("d5").Value & " // " & CMF

End Sub



To explain a bit of what I'm trying to do, I'm trying to have the macro send an email and update the subject line of the email with specific information helpful to my work.

By the way...COF and CMF are both variables relative to my work. :thumb

The problem I'm having is getting it to display the amount of unique COFs...The first thing in the code is assigning a speific cell an excel formula to calculate the amount of unique values.

Depending on the number, this is what I'm trying to do:
1) If amount of unique values =1, then display that 1 value in the subject line (or equal to variable CMF)
2) If amount of unique values = 2, I want both of those unique COFs to be equal to CMF
3) If amount of unique COFs in column = 3, then CMF shows the text "multiple COFs"

#s 1 and 3 works perfectly but if there are 2 unique values in the column, it gives fits. Could somebody help? I tried IFs which didn't work and can't figure out how to loops either.

PianoMan5
10-21-2011, 05:45 PM
I thought also maybe doing an advanced filter for unique values would work as I could just assign variables to the necessary cell values.

(via OZGrid.com)

Columns(2).EntireColumn.Insert
Range("C15", Range("C65536").End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True


'Variables to equal cell values
First=Range("B1").Value
Second=Range("B2").Value

Columns(3).EntireColumn.Delete



I would assume this would be easier as once I have the desired results, I can simply delete the column created...again though, I can't figure it out.

Would anybody be able to help, please?

mancubus
10-22-2011, 05:40 PM
hi.

try this with a copy of your file.

one UDF to count, another to list the uniques in range may help.


Sub Send_Mail()
'http://www.vbaexpress.com/forum/showthread.php?t=39513

Dim ws As Worksheet
Dim unqCount As Long
Dim CMF As String

Set ws = ActiveSheet 'or Worksheets("Sheet1") or Worksheets("Daily_Mails"), etc.

With ws
unqCount = CountUniqueValues(.Range("B14:B50"))
If unqCount = 0 Then
MsgBox "Range is empty!", vbOKOnly + vbCritical, "E R R O R"
Exit Sub
ElseIf unqCount = 1 Or unqCount = 2 Then
CMF = UniqueValues(.Range("B14:B50"))
ElseIf unqCount >= 3 Then
CMF = "Multiple COFs"
End If
'Sending email along wih attached spreadsheet
Application.Dialogs(xlDialogSendMail).Show arg1:="yourname@email.com", _
arg2:="CMF " & .Range("D5").Value & " // " & CMF
End With

End Sub




Function CountUniqueValues(InputRange As Range) As Long
'http://www.exceltip.com/st/Count_unique_values_using_VBA_in_Microsoft_Excel/520.html

Dim UniqueValues As New Collection
Dim cl As Range

Application.Volatile

On Error Resume Next ' ignore any errors
For Each cl In InputRange
If Not cl = vbNullString Then
UniqueValues.Add cl.Value, CStr(cl.Value) ' add the unique item
End If
Next cl
On Error GoTo 0

CountUniqueValues = UniqueValues.Count

End Function




Function UniqueValues(InputRange As Range)
'http://www.ozgrid.com/forum/showthread.php?t=40545

Dim cell As Range
Dim tempList As Variant

tempList = ""

For Each cell In InputRange
If cell.Value <> "" Then
If InStr(1, tempList, cell.Value) = 0 Then
If tempList = "" Then
tempList = Trim(CStr(cell.Value))
Else
tempList = tempList & ", " & Trim(CStr(cell.Value))
End If
End If
End If
Next cell

UniqueValues = tempList

End Function