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.

[VanChester]

So after looking into it with a colleague,

I have identified a pattern of when it does not work.

Once the code finds "[term] - Competency", the steps are as follows:

1) Highlights the cell "[term] - Competency" in yellow
2) it looks for "[term] - [level of effort]" that has something written on the cell on the right from it.
3) Highlights the cell "[term] - [level of effort]" in purple
4) Copies the two cells on the right from it and pastes it next to "[term] - Competency"

Once the code has finished step 1, it is supposed to look for the cells below it and continue on step 2,3,4 But in the instances that it did not work, It identified the cell above it instead, which is empty, hence why it doesn't copy paste the details.

This screenshot should explain it.
Demonstration of the issue.jpg

Instead of the cell identifying "Connect - Low Effort" that is below "Connect - Competency", it identified the cell that was above it.

I don't understand why it does identify the one above in certain instances and why it does not in other instances.

Hope this helps clarify the issue.

[VanChester]

anyone?

[VanChester]

OK! After speaking with Erik Eidt (A specialist over at Codementor.io) he has found the issue:

There is missing a "after:=c" at the line "Set d = ..."

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, after:=c, 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

Now that I have added "after:=c" the code now works perfectly.

Thanks again to @mdmackillop and Erik Eidt at Codementor.io