Paste unique value in multiple columns

[chunu]

Hi,
1 have data in sheet1 range a2 to a60
The following code paste unique vales to another sheet in one column.
is it possible to paste unique data from a2 to a20 in sheet2 column a then from a21 to a40 in sheet2 column b and from a41 to a60 in sheet2 column c

Sub Uniques()


Dim c As Range, ar As Variant, var As Variant
Dim Rng As Range: Set Rng = Sheet2.Range("b2", Sheet2.Range("b" & Sheet1.Rows.Count).End(xlUp))


With Rng
With CreateObject("Scripting.Dictionary")
For Each c In Rng
var = .Item(c.Value)
Next c
ar = .Keys
End With
End With


Sheet2.Range("A2").Resize(UBound(ar) + 1) = Application.Transpose(ar)

Thanks

 

[Peter_SSs]

is it possible to paste unique data from a2 to a20 in sheet2 column a then from a21 to a40 in sheet2 column b and from a41 to a60 in sheet2 column c

So the red range is 19 rows and the two blue ranges are 20 rows. Just checking that that is exactly what you have/want rather than perhaps you have 3 equal sized ranges?

 

[chunu]

So the red range is 19 rows and the two blue ranges are 20 rows. Just checking that that is exactly what you have/want rather than perhaps you have 3 equal sized ranges?

Hi,
Thanks for reply all ranges are equal.

 

[Peter_SSs]

Thanks for reply all ranges are equal.

Then I will assume that your data is in the range A2:A61 in Sheet1

Sub List_Uniques()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, j As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2:A61").Value
  For i = 1 To 3
    d.RemoveAll
    For j = 1 To 20
      d(a((i - 1) * 20 + j, 1)) = 1
    Next j
    Sheets("Sheet2").Cells(2, i).Resize(d.Count).Value = Application.Transpose(d.Keys)
  Next i
End Sub

 

[chunu]

Then I will assume that your data is in the range A2:A61 in Sheet1

Sub List_Uniques()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, j As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2:A61").Value
  For i = 1 To 3
    d.RemoveAll
    For j = 1 To 20
      d(a((i - 1) * 20 + j, 1)) = 1
    Next j
    Sheets("Sheet2").Cells(2, i).Resize(d.Count).Value = Application.Transpose(d.Keys)
  Next i
End Sub

sir,
code is working well. But I did mistake in my question this code paste data in column a,b,c, Actualy i want data to be pasted in columns A,D,G,J.
sorry for the inconvenience

 

[Peter_SSs]

Actualy i want data to be pasted in columns A,D,G,J.

You can't put 3 lists into 4 columns so can you please clarify exactly what you have in Sheet1, where it is and how it should be divided up into those 4 columns?

 

[chunu]

You can't put 3 lists into 4 columns so can you please clarify exactly what you have in Sheet1, where it is and how it should be divided up into those 4 columns?

Sorry to bother you,
sheet1 total items will be 64, currently i have 38 items in sheet1.
when i add new item it should go to first empty row of sheet2 A column after 16 entries it should go to columns D then column G and J
sheet1 range a2:a65 should be divided in four columns.
Thanks

 

[Peter_SSs]

Sorry to bother you,

You are not bothering me but to offer a good solution, helpers need to well understand what you have and what you require. You are very familiar with your data and requirement, but we are not.
So now we understand that the amount of data is changing, not fixed - that is an important piece of information.

Your new description has also made me wonder about this from your first post.

unique data from a2 to a20 in sheet2 column a then from a21 to a40 in sheet2 column b and from a41 to a60 in sheet2 column c

To me, that sounded like we should simply look at A2:A20 and get the unique values from there
then look at A21:A40 and get the unique values from there etc
If that was so, a value in A2:A20 could occur again in A21:A40 where it would again be unique to that range.

However, your new description is making me think that perhaps we should look at all the data that there is in A2:A65 together and make a list of the unique item and then place them in the required columns (max 16 per column).
Is that the case?

 

[chunu]

Hi,
Thanks dear for your kind words.
we should look at all the data that there is in A2:A65 together and make a list of the unique item and then place them in the required columns (max 16 per column).
but remember currently i have data in A2 to A38 rest will be added later.
Thanks

However, your new description is making me think that perhaps we should look at all the data that there is in A2:A65 together and make a list of the unique item and then place them in the required columns (max 16 per column).
Is that the case?

 

[Peter_SSs]

we should look at all the data that there is in A2:A65 together and make a list of the unique item and then place them in the required columns (max 16 per column).
but remember currently i have data in A2 to A38 rest will be added later.

Thanks for the clarification. You could try this Worksheet_Change event code in a copy of your workbook. To implement ..
1. Right click the Sheet1 name tab and choose "View Code".
2. Copy and Paste the code below into the main right hand pane that opens at step 1.
3. Close the Visual Basic window & test by entering/editing/deleting one or more values in Sheet1 A2:A65 then check the results in Sheet2

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  If Not Intersect(Target, Range("A2:A65")) Is Nothing Then
    Set d = CreateObject("Scripting.Dictionary")
    a = Range("A2:A65").Value
    For i = 1 To UBound(a)
      If Len(a(i, 1)) > 0 Then d(a(i, 1)) = Empty
    Next i
    With Sheets("Sheet2")
      .Range("A2:A17,D2:D17,G2:G17,J2:J17").ClearContents
      For i = 0 To d.Count - 1
        .Cells(2 + i Mod 16, Int(i / 16) * 3 + 1).Value = d.keys()(i)
      Next i
    End With
  End If
End Sub