Copy transpose & merge Macro

REP013 · Aug 5th 2004

I have a list of names, in a column, I would like to be able to run a macro to copy the list (names only), merge each name into 3 cells (each name is in one cell only at the moment) and transpose them so they are column headers.

I'm sure I can figure out a way to do this but it would be very long winded and probabaly take me the best part of 24 hours, so I was hoping for some help, if there is a simple piece of code.

Any help, as ever, greatly appreciated.

Thanks

Ray

luceze · Aug 5th 2004

Not sure exactly what you are trying to do but this might work:

Code

Dim cell
Dim strName As String
Dim x As Integer
    For Each cell In Selection
        x = x + 1
        strName = cell & cell.Offset(0, 1) & cell.Offset(0, 2)
        Cells(1, x + 3) = strName
    Next

REP013 · Aug 5th 2004

Thanks for the help, unfortunately it isn't exactly what I require.

I need to transpose a list from a column to a row in another sheet at the same time insert two columns between each entry and then merge each entry with the 2 added columns.

The SS attached shows what I need to do but as yet I can't figure out the code apart from the record MACRO which long term doesn't suffice.

jindon · Aug 6th 2004

Hi,

try this

Code

Sub Test002()
    Dim i, lastA, lastC As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Input")
    Set ws2 = Sheets("Output")
        With ws2.Range("1:1")
            .MergeCells = False
            .ClearContents
        End With
            lastA = ws1.Range("a65536").End(xlUp).Row
        For i = 2 To lastA
            If ws2.Range("a1") = "" Then
                lastC = 1
            Else
                lastC = ws2.Range("iv1").End(xlToLeft).Column + 3
            End If
            With ws2.Cells(1, lastC)
                .Value = ws1.Cells(i, 1).Value
                .Resize(, 3).MergeCells = True
                .HorizontalAlignment = xlCenter
            End With
        Next
End Sub

Display More

hope it helps

REP013 · Aug 6th 2004

Jindon, I am impressed, very nice code and it does the job exactly as I wanted.....Another thing learnt too!

Thank you very much for this.

Ray

REP013 · Aug 6th 2004

Jindon, could this code be improved slightly in that there may already be data in A1, B1 etc. so that the copy and paste starts after the data that is already there?

I assume that the following code has something to do with this?

With ws2.Range("1:1")
.MergeCells = False
.ClearContents

If it does / doesn't could you please explain what this does...the .Range("1:1") part?

Thanks again.

Ray

jindon · Aug 6th 2004

Hi,
try this
select the cell first then run this vba code
regarding Test002:
can you add following two lines just before End Sub
Set ws1 = Nothing
Set ws2 = Nothing

Code

Sub Test003()
    Dim lastC As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Input")
    Set ws2 = Sheets("Output")
            lastC = ws2.Range("iv1").End(xlToLeft).Column + 3
        With ws2.Cells(1, lastC)
            .Value = ActiveCell.Value
            .Resize(, 3).MergeCells = True
            .HorizontalAlignment = xlCenter
        End With
     Set ws1 = Nothing
     Set ws2 = Nothing
End Sub

Display More

REP013 · Aug 6th 2004

Jindon, thanks but I don't understand what you have asked me to do?

I tried test003 and it doesn't work?

I tried adding the WS1 Set to Nothing before end sub and that still overwrites any data that is already in the Row 1 of the Output WS.

Thanks for your persistence with this!

Ray

REP013 · Aug 6th 2004

Jindon, no problem I have mofified your code and it now passes over any data that is already in the 1st Row

Code

Dim i, lastA, lastC As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Input")
    Set ws2 = Sheets("Output")
    'With ws2.Range("1:1")
    '    .MergeCells = False
    '    .ClearContents
    'End With
    lastA = ws1.Range("a65536").End(xlUp).Row
    For i = 2 To lastA
        If ws2.Range("a1") = "" Then
            lastC = 1
        Else
            lastC = ws2.Range("iv1").End(xlToLeft).Column + 3
        End If
        With ws2.Cells(1, lastC)
            .Value = ws1.Cells(i, 1).Value
            .Resize(, 3).MergeCells = True
            .HorizontalAlignment = xlCenter
        End With
    Next
    'Set ws1 = Nothing
    'Set ws2 = Nothing

Display More

Thanjks again for your assistance with this. The issue appeared to be the deletion of anything that was already in ws2 so I have blanked that piece of code. Tried with and without resetting the ws on exit and works both ways.

I assume the set to nothing on exit is to "close it off"?

Thanks again for your help.

Ray

jindon · Aug 6th 2004

Hi, Ray

glad to hear that you solved for yourself.

set ws ... nothing is to clear memory.

jindon

Copy transpose & merge Macro

Participate now!

Share

Users Viewing This Thread