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

Thank you for your help.
LVL 11
Wilder1626Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Should the results for Mike be 59 or 59, 59?
0
Martin LissOlder than dirtCommented:
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

0
Martin LissOlder than dirtCommented:
If you just want to see 59 once 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
Dim strParts() As String
Dim lngName As Long
Dim bDupe As Boolean

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
            strParts = Split(wsR.Cells(rngName.Row, "B"))
            bDupe = False
            For lngName = 0 To UBound(strParts)
                If strParts(lngName) = .Cells(lngRow, "K") Then
                    bDupe = True
                    Exit For
                End If
            Next
            If Not bDupe Then
                wsR.Cells(rngName.Row, "B") = wsR.Cells(rngName.Row, "B") & ", " & .Cells(lngRow, "K")
            End If
        End If
    Next
End With

End Sub

Open in new window

0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

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

Let me test this and i will get back to you.
0
Rgonzo1971Commented:
Hi,

pls try
Sub Macro()
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("a2:a" & lr)
    If dict.exists(c.Value) Then
        If Not "," & dict.Item(c.Value) & "," Like "*," & c.Offset(, 1).Value & ",*" Then
            dict.Item(c.Value) = dict.Item(c.Value) & "," & c.Offset(, 1).Value
        End If
    Else
        dict.Add Key:=c.Value, Item:=c.Offset(, 1).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)

End Sub

Open in new window

Regards
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Wilder1626Author Commented:
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

0
Martin LissOlder than dirtCommented:
I don't see that result.
 Cursor_and_Microsoft_Excel.jpg29081197.xlsm
0
Wilder1626Author Commented:
Martin, i must of tweak it wrong. let me look at it.
0
Martin LissOlder than dirtCommented:
If you still have a problem then please post your code.
0
Wilder1626Author Commented:
Actually, everything is good now. It was my fault. I did something wrong while tweaking the code.
0
Wilder1626Author Commented:
Thank a lot for you help. both are very good option. This is working great.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.