Make List Selection Copy Column Data from Another Worksheet - vba

Question

With the help of the stack community I have developed a piece of code that takes each column heading in one workbook and creates a list of those headings in another workbook. Now I want a piece of code that will copy the entire column of the selected heading.
Here is the code that creates the list:
Private Sub Main()
Application.ScreenUpdating = False
Set wb2 = ThisWorkbook
Dim foldername As Variant
Dim wb1 As Workbook
foldername = Application.GetOpenFilename
If foldername <> False Then
Set wb1 = Workbooks.Open(foldername)
Application.ScreenUpdating = True
Dim destination As Worksheet
Dim emptyColumn As Long
Dim lastFullColumn As Long
Dim emptyColumnLetter As String
Dim lastFullColumnLetter As String
Dim ws1 As Worksheet
Dim rng1 As Range
Dim ws2 As Worksheet
Dim rng2 As Range
Set ws2 = wb2.Sheets(1)
Set ws1 = wb1.Sheets(1)
Dim lastFullColumn1 As Long
Dim lastFullColumn2 As Long
Set destination = ws2
'Find the last column with something on the first row
lastFullColumn = destination.Cells(1, destination.Columns.Count).End(xlToLeft).Column
If lastFullColumn > 1 Then
emptyColumn = lastFullColumn + 1
End If
'Create the list with rows titles
lastFullColumn1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
lastFullColumn2 = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column + 1
Set rng1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, lastFullColumn1))
Set rng2 = ws2.Range(ws2.Cells(1, lastFullColumn2), ws2.Cells(lastFullColumn1, lastFullColumn2))
rng2.Value2 = Application.Transpose(rng1)
With ws2.Range("E14").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=" & rng2.Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "LIST"
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End Sub
And for the code that makes the list copy when a selection is selected, I was thinking something along these lines, but I can't quite get it to work:
Sub CopyHeadings()
If Target.Address = Range("E14").Address Then
For i = 1 To lastFullColumn1
If Range("E14").Value = Range(i).Value Then
wb1.Sheets("Sheet1").Columns(i).Copy destination:=wb2.Sheets("Sheet1").Columns(emptyColumn)
End If
Next i
End If
End Sub
I feel like looping across the first row through all the columns in the first workbook, then if it comes across a value that matches the value in the cell on workbook 2 where the list is, having it copy that entire column from workbook 1 to the next open column on the second workbook would work, but if someone has a better plan of attack, I'd love to hear it, Thanks!
So I tried going off of your example and this is what I have:
Public Sub CopyHeadings(ByRef ws1 As Worksheet, ByRef ws2 As Worksheet, Target As Range)
Dim i As Long
Dim lastFullColumn1 As Long
Dim rngE14 As Range
Set rngE14 = ws2.Range("E14").Value
lastFullColumn1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
If Target.Address = ws2.Range("E14").Address Then
For i = 1 To lastFullColumn1
If rngE14 = ws1.Range(i).Value Then ws1.Columns(i).Copy ws2.Columns(i)
Next i
End If
End Sub
It isn't returning any errors, but it still isn't copying and pasting any information from ws1 to ws2. It just has me choose a macro, and then it runs that macro. CopyHeadings doesn't come up on the list though of macros to run though.

Answer 1

There are variables out of scope in sub CopyHeadings (this is not tested so adjust it accordingly)
Public Sub CopyHeadings(ByRef ws1 As Worksheet, ByRef ws2 As Worksheet, Target As Range)
Dim i As Long, lastCol1 As Long, rngE14 As Range
rngE14 = ws2.Range("E14").Value
lastCol1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
If Target.Address = ws2.Range("E14").Address Then
For i = 1 To lastCol1
If rngE14 = ws1.Range(i).Value Then ws1.Columns(i).Copy ws2.Columns(i)
Next i
End If
End Sub
Test sub:
Public Sub testColumnCopy()
Dim ws1 As Worksheet, ws2 As Worksheet, fileID As Variant
fileID = Application.GetOpenFilename
If fileID <> False Then
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = Workbooks.Open(fileID).Sheets("Sheet1")
CopyHeadings ws1, ws2, ws2.Range("E14")
End If
End Sub
.
Your main sub:
Option Explicit
Private Sub Main()
Dim wb1 As Workbook, ws1 As Worksheet, rng1 As Range
Dim wb2 As Workbook, ws2 As Worksheet, rng2 As Range
Dim wsDest As Worksheet, fileID As Variant, emptyCol As Long
Dim lastCol As Long, lastCol1 As Long, lastCol2 As Long
Set wb2 = ThisWorkbook
fileID = Application.GetOpenFilename
If fileID <> False Then
Set wb1 = Workbooks.Open(fileID)
Set ws1 = wb1.Sheets("Sheet1")
Set ws2 = wb2.Sheets("Sheet1")
Set wsDest = ws2
'Last column containing data
lastCol = wsDest.Cells(1, wsDest.Columns.Count).End(xlToLeft).Column
If lastCol > 1 Then emptyCol = lastCol + 1
'Create the list with rows titles
lastCol1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
lastCol2 = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column + 1
Set rng1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, lastCol1))
Set rng2 = ws2.Range(ws2.Cells(1, lastCol2), ws2.Cells(lastCol1, lastCol2))
rng2.Value2 = Application.Transpose(rng1)
With ws2.Range("E14").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=" & rng2.Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "LIST"
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End Sub