Copy paste Cell inside Table under certain conditions 2

[VanChester]

Hello Everyone,

A couple of months ago I posted a request for help with VBA coding on Excel to be able to copy paste cells inside a table under certain conditions.
here is the original thread: (I would like to thank @mdmackillop for all the help he provided)

http://www.vbaexpress.com/forum/showthread.php?60106-Copy-paste-Cell-inside-Table-under-certain-conditions

The issue I currently am having is that I noticed that the provided code copy pastes almost all the cells needed but not all.

There have been some changes in the wording and here they are:

I used to have a total of 5 terms:
"Connect - Competency"
"Understand - Competency"
"Solve - Competency"
"Explore - Competency"
"Agree - Competency"

Now, I have 4 terms:
"Connect - Competency"
"Understand & Solve - Competency"
"Explore - Competency"
"Agree - Competency"

the lines associated with the cells previously mentioned used to be called:
"Basic", Emerging", Effective", Advanced"

For example:
"Connect - Competency" will have "Connect - Basic", "Connect - Emerging", "Connect - Effective", "Connect - Advanced"
"Explore - Competency" will have "Explore - Basic", "Explore - Emerging", "Explore - Effective", "Explore - Advanced"

Now, the line below are called:
"High Effort", "Medium Effort", "Low Effort", "Effortless"

For example:
"Connect - Competency" will have "Connect - High Effort", "Connect - Medium Effort", "Connect - Low Effort", "Connect - Effortless"
"Explore - Competency" will have "Explore - High Effort", "Explore - Medium Effort", "Explore - Low Effort", "Explore - Effortless"

Here is a screenshot of when the code works: (See "Employee 1" in the excel sheet attached)
uhuhu.jpg

Here is a screenshot of when the code sometimes skips an element: (See "Employee 6" in the excel sheet attached)
did not work.jpg


Here is the slight modification I have made to the code:

Sub ListAreas()    Dim a, c, d, typ, FA
     
    Columns(12).Insert
    Range("L4") = "Sub Category"
     
    For Each a In rAreas(Sheets("data").[B4])
        With a.Columns(9).Cells
            Set c = .Find("Competency", lookat:=xlPart)
            FA = c.Address
            Do
                c.Select
                If c.Offset(, 1) <> "" Then
                    c.Interior.ColorIndex = 6 'debug
                    typ = Trim(Split(c, "-")(0)) & " - " & c.Offset(, 1)
                    Set d = .Find(typ, lookat:=xlWhole)
                    If Not d Is Nothing Then
                        d.Interior.ColorIndex = 7 'debug
                        d.Offset(, 1).Copy c.Offset(, 2)
                        d.Offset(, 3).Copy c.Offset(, 3)
                        c.Offset(, 2).Resize(, 2).WrapText = True
                        c.Rows.AutoFit
                    End If
                End If
                Set c = .Find("Competency", after:=c, lookat:=xlPart)
            Loop Until c.Address = FA
        End With
    Next a
End Sub
 
 
Function rAreas(Cel As Range)
     'http://www.vbaexpress.com/forum/showthread.php?_
     '60005-Store-rows-in-dictionary-or-collection&p=364471&viewfull=1#post364471
    Dim oDict As Object
    Dim rData As Range, rTemp As Range
    Dim iRow As Long
    Dim v As Variant
    Dim sKey As String
    Dim arr As Variant
     
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = vbTextCompare
    Set rData = Cel.CurrentRegion
    rData.Select
    For iRow = 2 To rData.Rows.Count
        sKey = CStr(rData.Cells(iRow, 1).Value)
        If oDict.exists(sKey) Then
            Set rTemp = oDict(sKey)
            Set rTemp = Union(rTemp, rData.Rows(iRow))
            Set oDict(sKey) = rTemp
        Else
            oDict.Add sKey, rData.Rows(iRow)
        End If
    Next iRow
    rAreas = oDict.items
    Set oDict = Nothing
End Function


Sub ListAreas2()
    Dim a, c, d, typ, FA
     
    Columns(12).Select
    Range("L4") = "Sub Category"
     
    For Each a In rAreas(Sheets("data").[B4])
        With a.Columns(9).Cells
            Set c = .Find("Compliance", lookat:=xlPart)
            FA = c.Address
            Do
                c.Select
                If c.Offset(, 1) <> "" Then
                    c.Interior.ColorIndex = 6 'debug
                    typ = Trim(Split(c, "-")(0)) & " - " & c.Offset(, 1)
                    Set d = .Find(typ, lookat:=xlWhole)
                    If Not d Is Nothing Then
                        d.Interior.ColorIndex = 7 'debug
                        d.Offset(, 1).Copy c.Offset(, 2)
                        d.Offset(, 3).Copy c.Offset(, 3)
                        c.Offset(, 2).Resize(, 2).WrapText = True
                        c.Rows.AutoFit
                    End If
                End If
                Set c = .Find("Compliance", after:=c, lookat:=xlPart)
            Loop Until c.Address = FA
        End With
    Next a
End Sub
 
 
Function rAreas2(Cel As Range)
     'http://www.vbaexpress.com/forum/showthread.php?_
     '60005-Store-rows-in-dictionary-or-collection&p=364471&viewfull=1#post364471
    Dim oDict As Object
    Dim rData As Range, rTemp As Range
    Dim iRow As Long
    Dim v As Variant
    Dim sKey As String
    Dim arr As Variant
     
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = vbTextCompare
    Set rData = Cel.CurrentRegion
    rData.Select
    For iRow = 2 To rData.Rows.Count
        sKey = CStr(rData.Cells(iRow, 1).Value)
        If oDict.exists(sKey) Then
            Set rTemp = oDict(sKey)
            Set rTemp = Union(rTemp, rData.Rows(iRow))
            Set oDict(sKey) = rTemp
        Else
            oDict.Add sKey, rData.Rows(iRow)
        End If
    Next iRow
    rAreas = oDict.items
    Set oDict = Nothing
End Function

The modifications I have made are because I had to make the excel do the same thing with what ends with "Compliance". So I copied the code, named it "ListAreas2" and changed "Competency" to "Compliance".

Here is a copy of the excel file I have used on the screenshots (See attachment called Data with issues)

Your help is greatly appreciated.