Copy random cells to another worksheet

(Sheet1)I have 4 columns of data, each has a different number of cells in the range.

On another sheet (SHEET2), i have 4 dropdown boxes with the names of the columns mentioned above.

When i click the command button on sheet 2, i need the code to select a random cell from the columns (sheet1) corresponding to the dropdown box selection. It then needs to copy and paste the 4 selected cells to a range on sheet 2. In addition to this, i then need to concat the 4 cells to another cell on sheet 2, with a ", " inbetween each.

Dropdown cells are in K8-K11 in sheet 2, random cells to be pasted in M8-M11 in sheet 2 Columns to select random cells from are P-S in sheet 1 (sheet2 K8=sheet1 column p=sheet2 M8 etc)

The code i have is long and clunky, i would really love to have it neatened up and running smoother, and im sure there are much better ways to do it than i have done...:

Private Sub CommandButton2_Click()
Dim p As Range, q As Range, r As Range, s As Range
Dim c As Collection, d As Collection, e As Collection, f As Collection
Dim RNG1 As Range, RNG2 As Range, RNG3 As Range, RNG4 As Range
Dim LastRow1 As Long, LastRow2 As Long, LastRow3 As Long, LastRow4 As Long
Dim randomCell1 As Long, randomCell2 As Long, randomCell3 As Long, 
randomCell4 As Long
Dim Names As String

Worksheets("Contents").Activate

' Aoluwei's Blade
    Set c = New Collection
        LastRow1 = Worksheets("Contents").Range("P" & 
Rows.Count).End(xlUp).Row
    Set RNG1 = Worksheets("Contents").Range("P1:P" & LastRow1)


    For Each p In RNG1
        If p.Value <> "" Then
            c.Add p
        End If
    Next p
    Dim G As Long
        G = Application.WorksheetFunction.RandBetween(1, c.Count)
    Set pselect = c.Item(G)
        ' pselect.Activate
        pselect.Copy
        ' Range("T2").Activate
        Worksheets("Contents").Range("T2").PasteSpecial

' Canas Enlightenment
    Set d = New Collection
        LastRow2 = Worksheets("Contents").Range("Q" & 
Rows.Count).End(xlUp).Row
    Set RNG2 = Worksheets("Contents").Range("Q1:Q" & LastRow1)


    For Each q In RNG2
        If q.Value <> "" Then
            d.Add q
        End If
    Next q
    Dim H As Long
        H = Application.WorksheetFunction.RandBetween(1, d.Count)
    Set qselect = d.Item(H)
        ' qselect.Activate
        qselect.Copy
        ' Range("T3").Activate
        Worksheets("Contents").Range("T3").PasteSpecial

' Rangers Song
    Set e = New Collection
        LastRow3 = Worksheets("Contents").Range("R" & 
Rows.Count).End(xlUp).Row
    Set RNG3 = Worksheets("Contents").Range("R1:R" & LastRow1)


    For Each r In RNG3
        If r.Value <> "" Then
            e.Add r
        End If
    Next r
    Dim I As Long
        I = Application.WorksheetFunction.RandBetween(1, e.Count)
    Set rselect = e.Item(I)
        ' rselect.Activate
        rselect.Copy
        ' Range("T4").Activate
        Worksheets("Contents").Range("T4").PasteSpecial

' Abyss' Roar
    Set f = New Collection
        LastRow4 = Worksheets("Contents").Range("S" & 
Rows.Count).End(xlUp).Row
    Set RNG4 = Worksheets("Contents").Range("S1:S" & LastRow1)


    For Each s In RNG4
        If s.Value <> "" Then
            f.Add s
        End If
    Next s
    Dim J As Long
        J = Application.WorksheetFunction.RandBetween(1, f.Count)
    Set sselect = f.Item(J)
        ' sselect.Activate
        sselect.Copy
        ' Range("T5").Activate
        Worksheets("Contents").Range("T5").PasteSpecial

    Worksheets("Contents").Range("T2:T5").Copy


Worksheets("Home").Activate
    Range("M8:M11").PasteSpecial

' Dim Names As String

    ' Set Names = Join("M8:M11", ", ")
    ' Names.Copy
    ' Range("K12").PasteSpecial
End Sub

Any help to clean this up would be awesome. I have looked all around, but can only find code to select from 1 column....

Thank in Advance :) Cheers, Nat