Generating a Random List of Questions & Answers - VBA?

I suspect that this might be quite easy for you VBA pros, but here goes!

I have a file with two columns laid out thus:

Excel 2016 (Windows) 32 bit

	A	B
1	Q1	A1
2	Q2	A2
3	Q3	A3

Sheet: Sheet1

Column A contains questions and column B contains answers. I want to be able to enter my pairs of Qs and As and then, at the push of a button, generate random pairs of answers and questions thus:

Excel 2016 (Windows) 32 bit

	C
1	A3
2	Q1
3
4	A1
5	Q2
6
7	A2
8	Q3

Sheet: Sheet1

The list of Qs and As needs to be any length - usually between 16 and 24 rows of data. The random output needs to ensure that no matching pair ends up together.

Any ideas?

Duplicate posing

I think this will do what you want.
You should adjust the ranges to suit.
If you want less than all the questions in the result, adjust the Size variable.

Sub test()
    Dim baseData As Variant
    Dim randomizedData() As String
    Dim Size As Long
    Dim i As Long, temp As Variant, randIndex As Long
    
    baseData = Range("A1:b5").Value
    Size = UBound(baseData, 1)
    
    Rem randomly re-order the question/answers
    For i = 1 To Size
        randIndex = WorksheetFunction.RandBetween(1, Size)
        temp = baseData(i, 1)
        baseData(i, 1) = baseData(randIndex, 1)
        baseData(randIndex, 1) = temp
        temp = baseData(i, 2)
        baseData(i, 2) = baseData(randIndex, 2)
        baseData(randIndex, 2) = temp
    Next i
    
    Rem put into column array
    ReDim randomizedData(1 To 3 * Size, 1 To 1)
    For i = 0 To Size - 1
        randomizedData(3 * i + 1, 1) = baseData(i + 1, 1)
        randomizedData(3 * i + 2, 1) = baseData(i + 1, 2)
    Next i
    
    Rem put on sheet
    Range("C1").Resize(3 * Size, 1) = randomizedData
End Sub

The OP asks to randomize the question/answer pairs. (And then re-arrange them into a column.) The OP request (as I read it), does not change the correspondence between a question and its answer.

Maybe :

Sub Test()
  Dim a(), b(), c As New Collection, i As Long, j As Long
  a = Range("A1").CurrentRegion.Value
  ReDim b(1 To UBound(a, 1))
loop1:
  Set c = Nothing
  For i = 1 To UBound(b): c.Add i: Next i
  For i = 1 To UBound(b) - 1
loop2:
      j = Int(Rnd * c.Count) + 1
      If c(j) <> i Then
         b(i) = c(j)
         c.Remove j
      Else
         GoTo loop2
      End If
  Next i
  If UBound(b) <> c(1) Then b(UBound(b)) = c(1) Else GoTo loop1
  Set c = Nothing
  For i = 1 To UBound(b): c.Add Array(i, b(i)): Next i
  ReDim b(1 To UBound(b) * 3, 1 To 1)
  For i = 1 To UBound(a, 1)
      j = Int(Rnd * c.Count) + 1
      b(3 * i - 2, 1) = a(c(j)(0), 2)
      b(3 * i - 1, 1) = a(c(j)(1), 1)
      c.Remove j
  Next i
  Columns("D").ClearContents
  Range("D1").Resize(UBound(b, 1)).Value = b
End Sub