remove duplicates and delete cells...

**OfficerSpock** · 02-20-2009, 06:40 PM

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.

  ' 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

**Leith Ross** · 02-20-2009, 09:06 PM

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.

  ' 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

**OfficerSpock** · 02-26-2009, 12:47 PM

Lieth,

Thank you for your assistance. I had some issues with my account, so I am finally able to reply to your code.

The duplicates are removed as well as blank cells, but I am now ending up with an extra blank cell in Columns A and B whenever a duplicate scenario is present.

I tried to add an additional valule to my stopsort value (stopsort = querystart + 1), but that didn't make a difference.

I will try removing the action of place the value "Software" in Column A to see if that makes a difference.

Again, sorry for the late reply and thank you for your assistance!

John

**OfficerSpock** · 02-26-2009, 12:50 PM

Commenting out the line..

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

**OfficerSpock** · 04-23-2009, 02:59 PM

This thread can be marked as SOLVED. I'm unable to see an EDIT button anywhere or I would do it myself.

I had to work on other projects prior to getting back to this one. I still have an issue where some blank cells are left behind, but the intitial removing of duplicates and deleting the cells of the removed dups is taken care of!