VanChester
11-21-2017, 10:13 AM
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.
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.