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 (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)
20998

Here is a screenshot of when the code sometimes skips an element: (See "Employee 6" in the excel sheet attached)
20999


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.
21004

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