Copy transferred data

[ddoctor]

Long story short, I'm really having a though time figuring out a code to make this

Jess	Class1
Jake	Class2
Zach	Class3
Kate	Class4

<tbody>
</tbody>

Do this

Jess	Class1
Jess	Class2
Jess	Class3
Jess	Class4
Jake	Class1
Jake	Class2
Jake	Class3
Jake	Class4
Zach	Class1
Zach	Class2
Zach	Class3
Zach	Class4
Kate	Class1
Kate	Class2
Kate	Class3
Kate	Class4

<tbody>
</tbody>

 

[ddoctor]

Any help is greatly appreciated, this is the last piece of information I need to finish a project I've been working on for a few days now

 

[ParamRay]

With the cells selected, run this code.

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
  
  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 c1 In rngSelection.Columns(1).Cells
      If Not IsEmpty(c1.Value) Then
        For Each c2 In rngSelection.Columns(2).Cells
          If Not IsEmpty(c2.Value) Then
            lngCounter = lngCounter + 1
            ReDim Preserve avntCartesian(1 To 2, 1 To lngCounter)
            avntCartesian(1, lngCounter) = c1.Value
            avntCartesian(2, lngCounter) = c2.Value
          End If
        Next c2
      End If
    Next c1
  End If
  
  If lngCounter > 0 Then
    avntCartesian = TranposeArray(avntCartesian)
    Set wksOutput = ThisWorkbook.Sheets.Add
    wksOutput.Range("A1:B1").Value = Array("Column1", "Column2")
    wksOutput.Range("A2:B2").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

 

[ddoctor]

While this code works exactly for what I was asking for, it's not quite what I'm trying to do.

I really apologize for not being more specific. I just tried to keep it simple because I have had a lot of ignored posts across many message boards and thought I could take this answer and edit towards what I am needing. I see now that this is not the case and I'm sorry for wasting any of your time. I'll elaborate more.

This spreadsheet has 3 tabs, a 'Training Log', 'Course List', and 'Roster'. Under the 'Roster' as of right now I can edit it, and it will automatically add or remove employees from the 'Training Log'. Under the 'Course List' I will be listing courses instructed every month and attaching that course to each employee. So from there I can edit that tab, and that also update the 'Training log'. As of right now all I've been able to muster is a Training Log that looks similar to this

7/31/17	Zach	Course1	Subject1
8/1/17	Kate	Course2	Subject2
8/2/17	Jess	Course3	Subject3
8/3/17	Jake	Course4	Subject4
8/4/17		Course5	Subject5
8/5/17		Course6	Subject6

<tbody>
</tbody>

Using this

Sub TransferData()
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet

    Set sht1 = ThisWorkbook.Sheets("ss2")
    Set sht2 = ThisWorkbook.Sheets("ss1")
    sht2.Range("E13:F213").Value = sht1.Range("D6:E206").Value
    sht2.Range("C13:C213").Value = sht1.Range("C6:C206").Value
    
    Dim my, c As Range
    d = Application.WorksheetFunction.CountA(Sheet1.Range("D:D"))
    Set my = Sheet1.Range("D13:D" & d)
    For Each c In my
    If c.Value = "" Then c.FormulaR1C1 = "=R[-1]C"
Next

End Sub

The only purpose of this as of yet is to transfer the courses to the 'Training Log', and Fill in any blank spaces under the names. The 2nd part was kinda of a preemptive solution to whatever answer I can get from this.

 

[ddoctor]

So I've been working with this code you've provided, and I've managed to get it pulling in 4 columns of data now. Originally It was creating a really long list of every match possible from those 4 rows, but after changing this part around:

For Each c1 In rngSelection.Columns(1).Cells
      If Not IsEmpty(c1.Value) Then
        For Each c2 In rngSelection.Columns(2).Cells
            If Not IsEmpty(c2.Value) Then
                For Each c3 In rngSelection.Columns(3).Cells
                    If Not IsEmpty(c3.Value) Then
                        For Each c4 In rngSelection.Columns(4).Cells
                            If Not IsEmpty(c1.Value) Then

I can get it to stop generating the last column, so I end up with something that looks like this

8/29/2017	Zachary	Test1	Test1
8/29/2017	Zachary	Test1	Test2
8/29/2017	Zachary	Test1	Test3
8/29/2017	Zachary	Test1	Test4
8/29/2017	Zachary	Test1	Test5
8/29/2017	Zachary	Test1	Test6
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test1
8/29/2017	Zachary	Test2	Test1

<tbody>
</tbody>

ect.

My question is, is there a change I'm missing that can tie c1,c3,and c4 together so those three columns are only looking at c2?

I'm trying to get something that looks like this and repeats for every name:

8/29/2017	Zachary	Test1	Test1
8/30/2017	Zachary	Test2	Test2
8/31/2017	Zachary	Test3	Test3
9/1/2017	Zachary	Test4	Test4
9/2/2017	Zachary	Test5	Test5
9/3/2017	Zachary	Test6	Test6

<tbody>
</tbody>

Here's the changes I made to the code so far

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
  
  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
          
            lngCounter = lngCounter + 1
            ReDim Preserve avntCartesian(1 To 4, 1 To lngCounter)
            avntCartesian(1, lngCounter) = c1.Value
            avntCartesian(3, lngCounter) = c3.Value
            avntCartesian(4, lngCounter) = c4.Value
            avntCartesian(2, lngCounter) = c2.Value
            
                  End If
                Next c4
              End If
            Next c3
          End If
        Next c2
      End If
    Next c1
    
  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
  Set c3 = Nothing
  Set c4 = 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

 

[ddoctor]

Realized a piece of the code was missing and was unable to edit the message, here's the full thing.

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
  
  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 c1 In rngSelection.Columns(1).Cells
      If Not IsEmpty(c1.Value) Then
        For Each c2 In rngSelection.Columns(2).Cells
            If Not IsEmpty(c2.Value) Then
                For Each c3 In rngSelection.Columns(3).Cells
                    If Not IsEmpty(c3.Value) Then
                        For Each c4 In rngSelection.Columns(4).Cells
                            If Not IsEmpty(c1.Value) Then
          
            lngCounter = lngCounter + 1
            ReDim Preserve avntCartesian(1 To 4, 1 To lngCounter)
            avntCartesian(1, lngCounter) = c1.Value
            avntCartesian(3, lngCounter) = c3.Value
            avntCartesian(4, lngCounter) = c4.Value
            avntCartesian(2, lngCounter) = c2.Value
            
                  End If
                Next c4
              End If
            Next c3
          End If
        Next c2
      End If
    Next c1
    
  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