Wilder1626
asked on
VBA transfer data from one cell to another
Hi
I need your help on a macro that would transfer data from cells into another sheets cells based on some rules.
In Sheet "TEST1" i have names in column C and counts in column K
In Sheet "RESULT" i have unique names in column A matching the names from sheet "TEST1" and i would like to put in column B all the distinct count's from Sheet "TEST1" separated by a comma.
If a number shows more than once for a name, it should only be shown once in the "RESULT" column B count cell.
example from TEST1:
Result from the macro in RESULT sheet
How can i do that.
Thank you for your help.
I need your help on a macro that would transfer data from cells into another sheets cells based on some rules.
In Sheet "TEST1" i have names in column C and counts in column K
In Sheet "RESULT" i have unique names in column A matching the names from sheet "TEST1" and i would like to put in column B all the distinct count's from Sheet "TEST1" separated by a comma.
If a number shows more than once for a name, it should only be shown once in the "RESULT" column B count cell.
example from TEST1:
Result from the macro in RESULT sheet
How can i do that.
Thank you for your help.
Should the results for Mike be 59 or 59, 59?
If it's the latter then
Sub GetCounts()
Dim wsT As Worksheet
Dim wsR As Worksheet
Dim lngLastRow As Long
Dim lngRow As Long
Dim rngName As Range
Dim lngNextRow As Long
Set wsT = ThisWorkbook.Worksheets("TEST1")
Set wsR = ThisWorkbook.Worksheets("RESULTS")
With wsT
lngLastRow = .Range("A1048576").End(xlUp).Row
lngNextRow = 1
For lngRow = 2 To lngLastRow
Set rngName = wsR.Cells.Find(What:=.Cells(lngRow, "A"), After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If rngName Is Nothing Then
lngNextRow = lngNextRow + 1
wsR.Cells(lngNextRow, "A") = .Cells(lngRow, "A")
wsR.Cells(lngNextRow, "B") = .Cells(lngRow, "K")
Else
wsR.Cells(rngName.Row, "B") = wsR.Cells(rngName.Row, "B") & ", " & .Cells(lngRow, "K")
End If
Next
End With
End Sub
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi Martin Liss, i would like to see only one 59.
Let me test this and i will get back to you.
Let me test this and i will get back to you.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi Martin, we are almost there. I'm just seeing the B column results starting with a comma.
Ex: ", 10, 68, 9" when i should see: "10, 68, 9"
Hi Rgonzo1971, i have tweaked a little your code and it looks good so far:
Ex: ", 10, 68, 9" when i should see: "10, 68, 9"
Hi Rgonzo1971, i have tweaked a little your code and it looks good so far:
Dim dataWS As Worksheet, resWS As Worksheet
Dim dict, x
Dim c As Range, lr As Long
Application.ScreenUpdating = False
Set dataWS = Sheets("TEST1")
lr = dataWS.Cells(Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For Each c In dataWS.Range("c2:c" & lr)
If dict.exists(c.Value) Then
If Not "," & dict.Item(c.Value) & "," Like "*," & c.Offset(, 8).Value & ",*" Then
dict.Item(c.Value) = dict.Item(c.Value) & "," & c.Offset(, 8).Value
End If
Else
dict.Add Key:=c.Value, Item:=c.Offset(, 8).Value
End If
Next
dictI = dict.items
dictK = dict.keys
Set resWS = Sheets("RESULT")
resWS.Range("A2:A" & UBound(dictK) + 2) = Application.Transpose(dictK)
resWS.Range("B2:B" & UBound(dictI) + 2) = Application.Transpose(dictI)
ASKER
Martin, i must of tweak it wrong. let me look at it.
If you still have a problem then please post your code.
ASKER
Actually, everything is good now. It was my fault. I did something wrong while tweaking the code.
ASKER
Thank a lot for you help. both are very good option. This is working great.