• Status: Solved
  • Priority: Low
  • Security: Public
  • Views: 67
  • Last Modified:

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.
0
Wilder1626
Asked:
Wilder1626
  • 5
  • 5
2 Solutions
 
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
Cloud Class® Course: Certified Penetration Testing

This CPTE Certified Penetration Testing Engineer course covers everything you need to know about becoming a Certified Penetration Testing Engineer. Career Path: Professional roles include Ethical Hackers, Security Consultants, System Administrators, and Chief Security Officers.

 
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
 
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: MCSA MCSE Windows Server 2012

This course teaches how to install and configure Windows Server 2012 R2.  It is the first step on your path to becoming a Microsoft Certified Solutions Expert (MCSE).

  • 5
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now