Copy transferred data

D

ddoctor

New Member
Joined
Aug 30, 2017
Messages
27
Long story short, I'm really having a though time figuring out a code to make this

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Jess
[/TD]
[TD]Class1
[/TD]
[/TR]
[TR]
[TD]Jake
[/TD]
[TD]Class2
[/TD]
[/TR]
[TR]
[TD]Zach
[/TD]
[TD]Class3
[/TD]
[/TR]
[TR]
[TD]Kate
[/TD]
[TD]Class4
[/TD]
[/TR]
</tbody>[/TABLE]

Do this

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Jess
[/TD]
[TD]Class1
[/TD]
[/TR]
[TR]
[TD]Jess
[/TD]
[TD]Class2
[/TD]
[/TR]
[TR]
[TD]Jess
[/TD]
[TD]Class3
[/TD]
[/TR]
[TR]
[TD]Jess
[/TD]
[TD]Class4
[/TD]
[/TR]
[TR]
[TD]Jake
[/TD]
[TD]Class1
[/TD]
[/TR]
[TR]
[TD]Jake
[/TD]
[TD]Class2
[/TD]
[/TR]
[TR]
[TD]Jake
[/TD]
[TD]Class3
[/TD]
[/TR]
[TR]
[TD]Jake
[/TD]
[TD]Class4
[/TD]
[/TR]
[TR]
[TD]Zach
[/TD]
[TD]Class1
[/TD]
[/TR]
[TR]
[TD]Zach
[/TD]
[TD]Class2
[/TD]
[/TR]
[TR]
[TD]Zach
[/TD]
[TD]Class3
[/TD]
[/TR]
[TR]
[TD]Zach
[/TD]
[TD]Class4
[/TD]
[/TR]
[TR]
[TD]Kate
[/TD]
[TD]Class1
[/TD]
[/TR]
[TR]
[TD]Kate
[/TD]
[TD]Class2
[/TD]
[/TR]
[TR]
[TD]Kate
[/TD]
[TD]Class3
[/TD]
[/TR]
[TR]
[TD]Kate
[/TD]
[TD]Class4
[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
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
 
Upvote 0
With the cells selected, run this code.

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
 
Upvote 0
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

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]7/31/17[/TD]
[TD]Zach[/TD]
[TD]Course1[/TD]
[TD]Subject1[/TD]
[/TR]
[TR]
[TD]8/1/17[/TD]
[TD]Kate[/TD]
[TD]Course2[/TD]
[TD]Subject2[/TD]
[/TR]
[TR]
[TD]8/2/17[/TD]
[TD]Jess[/TD]
[TD]Course3[/TD]
[TD]Subject3[/TD]
[/TR]
[TR]
[TD]8/3/17[/TD]
[TD]Jake[/TD]
[TD]Course4[/TD]
[TD]Subject4[/TD]
[/TR]
[TR]
[TD]8/4/17[/TD]
[TD][/TD]
[TD]Course5[/TD]
[TD]Subject5[/TD]
[/TR]
[TR]
[TD]8/5/17[/TD]
[TD][/TD]
[TD]Course6[/TD]
[TD]Subject6[/TD]
[/TR]
</tbody>[/TABLE]

Using this

HTML: 
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.
 
Last edited:
Upvote 0
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:

Code: 
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

[TABLE="width: 256"]
<tbody>[TR]
[TD="class: xl63, width: 64, align: right"]8/29/2017[/TD]
[TD="width: 64"] Zachary[/TD]
[TD="width: 64"]Test1[/TD]
[TD="width: 64"]Test1[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD]Test2[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD]Test3[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD]Test4[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD]Test5[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD]Test6[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/29/2017[/TD]
[TD] Zachary[/TD]
[TD]Test2[/TD]
[TD]Test1[/TD]
[/TR]
</tbody>[/TABLE]

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:
[TABLE="width: 256"]
<tbody>[TR]
[TD="class: xl63, width: 64, align: right"]8/29/2017[/TD]
[TD="width: 64"] Zachary[/TD]
[TD="width: 64"]Test1[/TD]
[TD="width: 64"]Test1[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/30/2017[/TD]
[TD] Zachary[/TD]
[TD]Test2[/TD]
[TD]Test2[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]8/31/2017[/TD]
[TD] Zachary[/TD]
[TD]Test3[/TD]
[TD]Test3[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]9/1/2017[/TD]
[TD] Zachary[/TD]
[TD]Test4[/TD]
[TD]Test4[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]9/2/2017[/TD]
[TD] Zachary[/TD]
[TD]Test5[/TD]
[TD]Test5[/TD]
[/TR]
[TR]
[TD="class: xl63, align: right"]9/3/2017[/TD]
[TD] Zachary[/TD]
[TD]Test6[/TD]
[TD]Test6[/TD]
[/TR]
</tbody>[/TABLE]

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

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
  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
 
Last edited:
Upvote 0
Realized a piece of the code was missing and was unable to edit the message, here's the full thing.

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
  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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Transfer Data from Access Database to Excel userform
Replies
0
Views
743
DanSMT
D
L
  • Question Question
VBA code for macro button not working to transfer row data to another worksheet
Replies
1
Views
297
rjwalker1973
R
wizau
  • Question Question
Shirt Size with 2x Conditions (Chest & Height)
Replies
8
Views
165
Peter_SSs
Peter_SSs
wizau
  • Solved
Nested IF statements, or a better way?
Replies
4
Views
332
wizau
wizau
J
  • Question Question
Vlookup into next blank column
Replies
4
Views
347
Vogateer
V

Forum statistics

Threads
1,223,893
Messages
6,175,248
Members
452,623
Latest member
cliftonhandyman

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top