VBA-issues refrencing multiple range selections

[ddoctor]

I'm trying to create a workbook where a range consisting of 4 columns is selected, and a macro is run to to duplicate information in the second column according to the amount of information input into the other three columns. For example:

I want to turn something like this:

<tbody>
</tbody>

8/29/2017	Zachary	Test1	Test1
8/30/2017	April	Test2	Test2
8/31/2017	Justin	Test3	Test3

<tbody>
</tbody>

Into This:

9/1/17	Zachary	Test1	Test1
9/2/17	Zachary	Test2	Test2
9/3/17	Zachary	Test3	Test3
9/1/17	April	Test1	Test1
9/2/17	April	Test2	Test2
9/3/17	April	Test3	Test3
9/1/17	Justin	Test1	Test1
9/2/17	Justin	Test1	Test1
9/3/17	Justin	Test1	Test1

<tbody>
</tbody>

As of right now using the code provide below, I'm only getting this:

9/1/17	Zachary	9/1/17	9/1/17
9/2/17	Zachary	9/2/17	9/2/17
9/3/17	Zachary	9/3/17	9/3/17
9/1/17	April	9/1/17	9/1/17
9/2/17	April	9/2/17	9/2/17
9/3/17	April	9/3/17	9/3/17
9/1/17	Justin	9/1/17	9/1/17
9/2/17	Justin	9/2/17	9/2/17
9/3/17	Justin	9/3/17	9/3/17

<tbody>
</tbody>

I've gotten this far because of the following code that someone from here gave me to play with. I have been messing with it and attempting to make it work for what I need because originally it only referenced 2 columns. After I figure this problem out, I'm going to be looking into ways to make it all happen on the same tab. I can probably figure that out myself, but I'm open to input on all things considered.

Public Sub CrossJoinSelection()
  Dim avntCartesian() As Variant
  Dim wksOutput As Worksheet
  Dim rngSelection As Range
  Dim lngCounter As Long
  Dim c1 As Range
  Dim c2 As Range
  Dim c3 As Range
  Dim c4 As Range
  
 
 Dim r1, r2, r3, myMultipleRange As Range
 Set r1 = Sheets("ss1").Range("c4")
 Set r2 = Sheets("ss1").Range("c3")
 Set r3 = Sheets("ss1").Range("c1")
 Set myMultipleRange = Union(r1, r2, r3)
 myMultipleRange.Font.Bold = True

  
  On Error GoTo ErrHandler
  If Not TypeOf Selection Is Range Then
    MsgBox "Selection must be a range.", vbExclamation
    GoTo ExitProc
  End If
  
  Set rngSelection = Intersect(Selection, Selection.Parent.UsedRange)
  If Not rngSelection Is Nothing Then
    For Each myMultipleRange In rngSelection.Columns(1).Cells
      If Not IsEmpty(myMultipleRange.Value) Then
        For Each c2 In rngSelection.Columns(2).Cells
            If Not IsEmpty(c2.Value) Then
                
               
          
            lngCounter = lngCounter + 1
            ReDim Preserve avntCartesian(1 To 4, 1 To lngCounter)
            avntCartesian(1, lngCounter) = myMultipleRange.Value
            avntCartesian(2, lngCounter) = c2.Value
            avntCartesian(3, lngCounter) = myMultipleRange.Value
            avntCartesian(4, lngCounter) = myMultipleRange.Value
                  End If
                Next c2
              End If
            Next myMultipleRange
       
    
  End If
  
  If lngCounter > 0 Then
    avntCartesian = TranposeArray(avntCartesian)
    Set wksOutput = ThisWorkbook.Sheets.Add
    wksOutput.Range("C13:F13").Value = Array("Column1", "Column2", "Column3", "Column4")
    wksOutput.Range("C13:F13").Resize(lngCounter).Value = avntCartesian
  Else
    MsgBox "No values found in selection.", vbExclamation
  End If
  
ExitProc:
  Set rngSelection = Nothing
  Set wksOutput = Nothing
  Set c1 = Nothing
  Set c2 = Nothing
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitProc
End Sub

Private Function TranposeArray(avntSource() As Variant) As Variant()
  Dim avntTarget() As Variant
  Dim intLower1 As Integer
  Dim intUpper1 As Integer
  Dim lngLower2 As Long
  Dim lngUpper2 As Long
  Dim i As Integer
  Dim j As Long
  
  intLower1 = LBound(avntSource, 1)
  intUpper1 = UBound(avntSource, 1)
  lngLower2 = LBound(avntSource, 2)
  lngUpper2 = UBound(avntSource, 2)
  
  ReDim avntTarget(lngLower2 To lngUpper2, intLower1 To intUpper1)
  For j = lngLower2 To lngUpper2
    For i = intLower1 To intUpper1
      avntTarget(j, i) = avntSource(i, j)
    Next i
  Next j
  
  TranposeArray = avntTarget
End Function

I appreciate what you guys do here! Thanks any help.

 

[Norie]

How do you get from the initial data in the table you posted to the result you want?

Is there any logic, patterns, rules?

 

[ddoctor]

How do you get from the initial data in the table you posted to the result you want?

Is there any logic, patterns, rules?

I suppose that would be better answered by the person that provided it to me, but after working with the code it appears that this section is what generates the pattern needed.

 ReDim avntTarget(lngLower2 To lngUpper2, intLower1 To intUpper1)
  For j = lngLower2 To lngUpper2
    For i = intLower1 To intUpper1
      avntTarget(j, i) = avntSource(i, j)
    Next i
  Next j

Originally it looked at only the first to columns, so it appeared to make sure each individual date would only replicate itself according the to amount of names entered into the 2nd column.

Originally when I began playing with it to include 4 columns, I would end up with an extremely long list because it would list every possible arrangement.

The code I provided above was an attempt to group columns 1,3,and 4 together. As of right now it assigns the dates correctly, but doesn't include the data from columns 3,4.

I hope that answers your question, I'm pretty new to all of this so I'm pretty sure there was a better way to describe what I'm saying lol