PDA

View Full Version : [SOLVED] Copy paste Cell inside Table under certain conditions



VanChester
07-17-2017, 07:38 AM
Hello Everyone,

I have a table where I would like execute a code to automate copying cells into other cells inside a table. The important columns for this table are J,K,L, and M. Using this picture I will help explain what I'm trying to do.

19774

The conditions are what are underlined in the various colors and the results I would like the code to execute are the arrows and squares.


Column J = Form Component Title
Column K = Answer Title
Column L = Sub Category
Column M = Form Component Comments


Under column J, The first one underlined is "Agree - Competency" and the cell on the right from it (under column K) is "Basic". What I would like for it to do is since the cell under column K is "Basic", then the code needs to look for "Agree - Basic" (which is on column J) and take the cell on the right of it (under column K and the cell under column M) and copy paste it into column L on the same row as the cell "Basic" (which is under column K).
One issue with this is that the order under Column J is not always the same and every 41 rows the data repeats itself. For example: for the range [J1-J40] we will have "Agree - Competency" in cell J3 but on the range [J41-81] it will have "Agree - Competency" in cell J46.

The reason it repeats itself is because every 41 rows it is a new person's data for a new entry.

I have includes a Picture of the requested result should look like.

19775
My current code is (just to insert Column L and name it Sub Category):


Sub CreateNewColumn()
'
' CreateNewColumn Macro
' Creates a new column between Anser Title and Form Components Comments called "Sub Catergory"
'


'
Columns("L:L").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("L4").Select
ActiveCell.FormulaR1C1 = "Sub Category"



End Sub


I have attached the actual Excel File That I'm trying to establish the code on.


19776


Your help is greatly appreciated. Thank you

mdmackillop
07-17-2017, 08:03 AM
Is this to be done for each user?
Are the two seach terms mentioned the only ones. Is there Connect-Basic or other combination to be processed in similar fashion?

VanChester
07-17-2017, 08:30 AM
Is this to be done for each user?
Are the two seach terms mentioned the only ones. Is there Connect-Basic or other combination to be processed in similar fashion?

Hey Thank you for your response.

1)
This is to be done for each user (for every 41 rows).

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

Just like how for "Agree - Competency" there are 4 separate rows "Agree - Basic", "Agree - Emerging", "Agree - Effective", "Agree - Advanced" the same applies to all 5 competencies.
For example: "Connect - Competency" will have "Connect - Basic", "Connect - Emerging", "Connect - Effective", "Connect - Advanced" etc...

There will be only 1 cell filled out on the right of the the 4 rows that have ("Connect - Basic", "Connect - Emerging" etc.). And that cell needs to be copied and pasted on the right of the cells "Basic" or "Emerging" or "Effective" or "Advanced" which are the cells that are on the right of "Connect - Competency", "Understand - Competency", "Solve - Competency", "Explore - Competency", "Agree - Competency".

Please let me know if I can clarify anything else.

mdmackillop
07-17-2017, 09:06 AM
Have a look at this. Selected cells coloured for clarity


Option Explicit

Sub ListAreas()
Dim a, c, d, typ, FA

Columns(12).Insert
Range("L4") = "Sub Category"

For Each a In rAreas(Sheets("Report 1").[B4])
With a.Columns(9).Cells
Set c = .Find("Competency", lookat:=xlPart)
FA = c.Address
Do
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

VanChester
07-27-2017, 08:00 AM
Have a look at this. Selected cells coloured for clarity



wow! worked perfectly. Thank you so much.


I played around with the code to add another function I was just told that needs to be done. The exact same thing needs to be done for "Authentication - Compliance", "KYC - Compliance", "Disclosures - Compliance".
To test if this code would work with the new set of textual values, I basically changed in the code "Competency" to "Compliance" and it worked. So what I did was copy paste the code at the end, Change "Sub ListAreas()" to "Sub ListAreas2()" and "Function rAreas(Cel As Range)" to "Function rAreas2(Cel As Range)", added a second button related to Sub ListArea2() and voila! it works!

Thank you mdmackillop for your help!