使列表select从另一个工作表复制列数据
在堆栈社区的帮助下，我开发了一段代码，它将每个列标题放在一个工作簿中，并在另一个工作簿中创build这些标题的列表。 现在我想要一段代码来复制所选标题的整个列。
这是创build列表的代码：
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 而对于selectselect时使列表复制的代码，我正在想这些方面的东西，但我不能完全得到它的工作：
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
我觉得像遍历第一行遍历第一个工作簿中的所有列，然后如果遇到与列表所在的工作簿2上的单元格中的值相匹配的值，请将该列中的整个列从工作簿1复制到在第二个工作簿上的下一个开放的列将工作，但如果有人有一个更好的攻击计划，我很乐意听到，谢谢！
所以我试图脱离你的例子，这就是我所拥有的：
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
它没有返回任何错误，但它仍然没有复制和粘贴从ws1到ws2的任何信息。 它只是让我select一个macros，然后运行这个macros。 CopyHeadings不会出现在列表中，尽pipemacros可以运行。
子CopyHeadings有超出范围的variables（这没有经过testing，因此相应调整）
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
testing子：
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
。
你的主要分：
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