VBA code issue copy multiple cells and transpose paste in different sheet

[Marius Nielsen]

I'm quite new to VBA and have a code which is not working correctly. Its working for a singel cell but not multiple cells selections.
Please note that selcted cells to be copied are merged cells so wonder if this is causing the issue.

Sub Main()
Call Nummber
Call Mail_ActiveSheet
Dim NextRow As Range
With Sheets("Database")
Set NextRow = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
End With
ThisWorkbook.Sheets("Ocean Export FCL").Range("e6,e5,e2,e1,e3,e4,e7,t2,t3,t4,af4,t5,t6,af6,ad19,y27").Copy
NextRow.PasteSpecial Paste:=xlValues, Transpose:=True
Application.CutCopyMode = False
Set NextRow = Nothing

ThisWorkbook.Save

Application.Quit
End Sub

Any chance for some help on this issue ? Thanks in advance.

 

[pbornemeier]

If you try that manually you will get an error message, "That command cannot be used on multiple selections". Which is why you are getting the error when you use the above code.
I believe this code will do what you are looking for:

Sub CopyTest()

    Dim rng As Range
    Dim rngCell As Range
    Dim rngTarget As Range
    Dim lCount As Long
    Dim lX As Long
    
    With Sheets("Database")
        'The next empty cell in column B would be:
        Set rngTarget = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
    End With
    
    Set rng = ThisWorkbook.Sheets("Ocean Export FCL").Range("e6,e5,e2,e1,e3,e4,e7,t2,t3,t4,af4,t5,t6,af6,ad19,y27")
    For Each rngCell In rng
        lX = lX + 1
        'Debug.Print rngCell.Address, rngCell.Value, rngTarget.Offset(0, lX - 1).Address, rngTarget.Offset(lX - 1, 0).Address
        rngTarget.Offset(0, lX - 1).Value = rngCell.Value 'For horzontal output
        'rngTarget.Offset(lX - 1, 0).Value = rngCell.Value 'For vertical output
    Next

End Sub

 

[Marius Nielsen]

If you try that manually you will get an error message, "That command cannot be used on multiple selections". Which is why you are getting the error when you use the above code.
I believe this code will do what you are looking for:

Sub CopyTest()

    Dim rng As Range
    Dim rngCell As Range
    Dim rngTarget As Range
    Dim lCount As Long
    Dim lX As Long
    
    With Sheets("Database")
        'The next empty cell in column B would be:
        Set rngTarget = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
    End With
    
    Set rng = ThisWorkbook.Sheets("Ocean Export FCL").Range("e6,e5,e2,e1,e3,e4,e7,t2,t3,t4,af4,t5,t6,af6,ad19,y27")
    For Each rngCell In rng
        lX = lX + 1
        'Debug.Print rngCell.Address, rngCell.Value, rngTarget.Offset(0, lX - 1).Address, rngTarget.Offset(lX - 1, 0).Address
        rngTarget.Offset(0, lX - 1).Value = rngCell.Value 'For horzontal output
        'rngTarget.Offset(lX - 1, 0).Value = rngCell.Value 'For vertical output
    Next

End Sub

This worked perfectly. Thanks for your support !

 

[pbornemeier]

You are welcome.