Thread: remove duplicates and delete cells...

I am using the following code to grab installed software on a remote computer through a macro in Excel 2007. I don't have the entire code I'm using as the majority of it works, this section here though is where I'm having problems.

Code:

  ' Retrieve software info
  Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
  strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
  strEntry1a = "DisplayName"
  strEntry1b = "QuietDisplayName"
 
  Set objItem = GetObject("winmgmts://" & objComp & "/root/default:StdRegProv")
      objItem.EnumKey HKLM, strKey, arrSubkeys
      ActiveSheet.Range("A" & QueryStart & "").Value = "Software"
      StartSort = QueryStart
      'MsgBox "Start Value " & StartSort
      For Each strSubkey In arrSubkeys
          intRet1 = objItem.GetStringValue(HKLM, strKey & strSubkey, strEntry1a, strValue1)
              If intRet1 <> 0 Then
                  objItem.GetStringValue HKLM, strKey & strSubkey, strEntry1b, strValue1
              End If
              If strValue1 <> "" Then
                  objSoftware.Add strValue1, strValue1
              End If
                              If strValue1 Like "*.NET F*" Then
                  ActiveSheet.Range("B" & QueryStart & "").Value = "" & strValue1 & ""
                          QueryStart = QueryStart + 1
              ElseIf strValue1 Like "MSXML*" Then
                              ActiveSheet.Range("B" & QueryStart & "").Value = "" & strValue1 & ""
                QueryStart = QueryStart + 1
              End If
      Next
      QueryStart = QueryStart + 1
      StopSort = QueryStart
      'MsgBox "Stop Value " & StopSort
 
  ' Sort retrieved software values
  ActiveSheet.Sort.SortFields.Clear
  ActiveSheet.Sort.SortFields.Add Key:= _
  Range("B" & StartSort & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  xlSortTextAsNumbers
  With ActiveSheet.Sort
      .SetRange Range("B" & StartSort & ":B" & StopSort & "")
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With

This code properly grabs the values I'm looking for and sorts them. So the proper output would be something like this...

......Column A.....Column B
1.....Software.....Microsoft .NET Framework 2.0 Service Pack 1
2..................MSXML 4.0
3..................MSXML 6 Service Pack 2 (KB954459)

That output is actually what I get for the majority of the machines, but there are some where I get multiple values for the same product returned like this...

......Column A.....Column B
1.....Software.....Microsoft .NET Framework 2.0
2..................Microsoft .NET Framework 2.0
3..................MSXML 4.0
4..................MSXML 4.0
5..................MSXML 6 Service Pack 2 (KB954459)

I had some code that removed the duplicates, but I was having a heck of a time deleting the cell in column B that held the duplicate value along with the corresponding blank cell in column A.

I ended up scrapping the code after pulling out my hair! So my question to y'all is do I look for logic that stores the values I'm getting from the remote machine's registry into an array, sort the array and remove duplicates or have Excel do the work for me after the fact?

Either way I have not been successful in my googling to find code showing a way to do either of the above solutions.

Forgive my coding (or lack there of) as I'm not knowledgable in the ways of VB (I overthought projects too much when I tried for a computer science major in college...ended up with a degree in communications instead).

Thanks so much in advance,
John

Hello Jon,

Welcome to the Forum!

The code I have added will remove duplicates in columns "A" and "B". The deletion process starts at the end of range and goes up. Where N is the last row, if row N - 1 = row N then cells "A" and "B" of row N - 1 are deleted. If cell "A" of row N - 1 has a value then that value is copied to cell "A" of row N before row N - 1 is deleted.

Code:

  ' Retrieve software info
  Dim I As Long
  Dim Rng As Range
  Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
  strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
  strEntry1a = "DisplayName"
  strEntry1b = "QuietDisplayName"
 
  Set objItem = GetObject("winmgmts://" & objComp & "/root/default:StdRegProv")
      objItem.EnumKey HKLM, strKey, arrSubkeys
      ActiveSheet.Range("A" & QueryStart & "").Value = "Software"
      StartSort = QueryStart
      'MsgBox "Start Value " & StartSort
      For Each strSubkey In arrSubkeys
          intRet1 = objItem.GetStringValue(HKLM, strKey & strSubkey, strEntry1a, strValue1)
              If intRet1 <> 0 Then
                  objItem.GetStringValue HKLM, strKey & strSubkey, strEntry1b, strValue1
              End If
              If strValue1 <> "" Then
                  objSoftware.Add strValue1, strValue1
              End If
                              If strValue1 Like "*.NET F*" Then
                  ActiveSheet.Range("B" & QueryStart & "").Value = "" & strValue1 & ""
                          QueryStart = QueryStart + 1
              ElseIf strValue1 Like "MSXML*" Then
                              ActiveSheet.Range("B" & QueryStart & "").Value = "" & strValue1 & ""
                QueryStart = QueryStart + 1
              End If
      Next
      QueryStart = QueryStart + 1
      StopSort = QueryStart
      'MsgBox "Stop Value " & StopSort
 
  ' Sort retrieved software values
  ActiveSheet.Sort.SortFields.Clear
  ActiveSheet.Sort.SortFields.Add Key:= _
  Range("B" & StartSort & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  xlSortTextAsNumbers
  With ActiveSheet.Sort
      .SetRange Range("B" & StartSort & ":B" & StopSort & "")
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
 'Remove Duplicates
    Set Rng = Range("A" & StartSort, "B" & StopSort)  
      For I = Rng.Rows.Count To 2 Step -1
        If Rng.Cells(I, 2) = Rng.Cells(I - 1, 2) Then
           If Rng.Cells(I - 1, 1) <> "" Then
              Rng.Cells(I, 1) = Rng.Cells(I - 1, 1)
           End If
           Rng.Rows(I - 1).Delete Shift:=xlShiftUp
        End If
      Next I

Commenting out the line..

Code:

ActiveSheet.Range("A" & QueryStart & "").Value = "Software"

...didn't make a difference. I thought maybe the non-blank cell value in Column A in the range was affecting the outcome, but that's not the case.

I have found out that depending on the number of duplicates, that's how many blank cells are left over in Columns A and B.

Thanks,
John