Link to home
Start Free TrialLog in
Avatar of Wilder1626
Wilder1626Flag for Canada

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:
User generated image
Result from the macro in RESULT sheet
User generated image
How can i do that.

Thank you for your help.
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

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

Open in new window

SOLUTION
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Wilder1626

ASKER

Hi Martin Liss, i would like to see only one 59.

Let me test this and i will get back to you.
ASKER CERTIFIED SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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:
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)

Open in new window

I don't see that result.
 User generated image29081197.xlsm
Martin, i must of tweak it wrong. let me look at it.
If you still have a problem then please post your code.
Actually, everything is good now. It was my fault. I did something wrong while tweaking the code.
Thank a lot for you help. both are very good option. This is working great.