Need help creating a VBA macro

[kasbac]

Hi there

I hope that someone out there will be able to help me with what I think might be a bit of a complex macro (at least more comples than I am capable off )

I will try to break down the requirements in a numbers of steps, please feel free to ask any questions for further details.

Step 1:
Clear data in "sheet1" from (and including) line 3 and downwards. - This will clear all old data.

Step 2:
In "sheet2" coulmn B i have a number of names listed. I want these pasted in to cell A3 in "sheet1" and downwards. Note that column B has a header that I do NOT need.

Step 3:
Some names are listed multiple times. I want all duplicate records to be removed so there is only one line per person in coulmn A in "sheet1".

Step 4 (the tricky part, at least i think ):
From cell B2 and outwards (C2, D2 etc) in "sheet1" I have some ID numbers. Some cells have one ID other has multiple IDs separated by ; in the same cell. For each person found in coulmn A in "sheet1" I now want to check if the ID found in line 2 is found in "sheet2" coulmn G. If this ID is not found in a line with their name "Not completed" should be marked in the corresponding coulmn in "sheet1". If an ID is found it should be marked as "Completed".

I hope the above make somewhat sense (especially step 4). If not please let me know of any clarifications needed.

Any help will be highly appreciated!

 

[Fluff]

How about

Sub kasbac()
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim Cl As Range
   Dim Ary As Variant, Sp As Variant
   Dim r As Long, c As Long, i As Long
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   Ws1.Range("3:" & Rows.Count).Clear
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("B2", Ws2.Range("B" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 5).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & ", " & Cl.Offset(, 5).Value
         End If
      Next Cl
      Ws1.Range("A3").Resize(.Count).Value = Application.Transpose(.Keys)
      Ary = Range("A2").CurrentRegion.Value2
      For r = 2 To UBound(Ary)
         For c = 2 To UBound(Ary, 2)
            Sp = Split(Ary(1, c), ";")
            For i = 0 To UBound(Sp)
               If InStr(1, .Item(Ary(r, 1)), Sp(i), vbTextCompare) > 0 Then
                  Ary(r, c) = "Completed"
                  Exit For
               Else
                  Ary(r, c) = "Not Completed"
               End If
            Next i
         Next c
      Next r
      Ws1.Range("A2").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
   End With
End Sub

 

[kasbac]

How about

Sub kasbac()
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim Cl As Range
   Dim Ary As Variant, Sp As Variant
   Dim r As Long, c As Long, i As Long
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   Ws1.Range("3:" & Rows.Count).Clear
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("B2", Ws2.Range("B" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 5).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & ", " & Cl.Offset(, 5).Value
         End If
      Next Cl
      Ws1.Range("A3").Resize(.Count).Value = Application.Transpose(.Keys)
      Ary = Range("A2").CurrentRegion.Value2
      For r = 2 To UBound(Ary)
         For c = 2 To UBound(Ary, 2)
            Sp = Split(Ary(1, c), ";")
            For i = 0 To UBound(Sp)
               If InStr(1, .Item(Ary(r, 1)), Sp(i), vbTextCompare) > 0 Then
                  Ary(r, c) = "Completed"
                  Exit For
               Else
                  Ary(r, c) = "Not Completed"
               End If
            Next i
         Next c
      Next r
      Ws1.Range("A2").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
   End With
End Sub

Thanks for looking in to this Fluff!

Unfortunately I am getting the following error "ActiveX component cant create object" and the line "With CreateObject("scripting.dictionary")" is highlighted when I try to run the macro?

 

[Fluff]

Are you running this on a Mac?

 

[kasbac]

Are you running this on a Mac?

Yep, and, with the fear of sounding to demanding, as I will not be the only user of the macro I would preferable need a macro that can run on both mac and and windows devices? Any chance this is possible?

Once again thanks for your inputs

 

[Fluff]

It's possible to have a macro that will run on both systems, but as I do not have a Mac I cannot help.
There are a number of things (such as dictionaries) that do not work on a Mac

 

[kasbac]

It's possible to have a macro that will run on both systems, but as I do not have a Mac I cannot help.
There are a number of things (such as dictionaries) that do not work on a Mac

Fully understandable Fluff, once again thanks for the attempt!

Anyone else out there that can help?