Code to move data in 1 column to multiple columns

[Pjam]

Hi,

I am trying to move data alot of data in one column to everyother column in the spreadsheet when an ID changes.


i have all this information in column A alot.

for example

i would like to see all 1's in B the next value 2 in column D etc any ideas?

1
1
1
1
1
2
2
2
2
2
3
3
3

 

[MickG]

Try :-

[COLOR=navy]Sub[/COLOR] MG31Mar40
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] oMax [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count, 1 To Columns.Count)
Ac = 1
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    c = c + 1
        oMax = Application.Max(c, oMax)
           Ray(c, Ac) = Dn
              [COLOR=navy]If[/COLOR] Dn <> Dn.Offset(1) [COLOR=navy]Then[/COLOR] Ac = Ac + 1: c = 0
                [COLOR=navy]Next[/COLOR] Dn
Rng.ClearContents
Range("A1").Resize(oMax, Ac) = Ray
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[Pjam]

This is good except i need this for every other column any ideas?

 

[AlphaFrog]

Sub Copy_IDs()
    
    Dim rngUniques As Range, rngFilter As Range, rngCopy As Range
    Dim cell As Range, counter As Long
    
    Application.ScreenUpdating = False
    
    ' Add header (temporary)
    Range("A1").Insert Shift:=xlDown
    Range("A1").Value = "IDs"
    
    Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
    Set rngCopy = Range("A2", Range("A" & Rows.Count).End(xlUp))
    
    rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = rngCopy.SpecialCells(xlCellTypeVisible)
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    
    For Each cell In rngUniques
        counter = counter + 1
        rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
        rngCopy.SpecialCells(xlCellTypeVisible).Copy Destination:=Cells(1, counter * 2)
    Next cell
    
    ActiveSheet.AutoFilterMode = False
    
    ' Remove header
    Range("A1").Delete Shift:=xlUp
    
    Application.ScreenUpdating = True
    
End Sub