创建循环以从三个工作表中复制整个列并将它们排序到新工作表中

Question

我是VBA的新手，在编写某个宏时遇到了问题。我从数据库中检索了大约150种债券的每日收益率，要价和买入价的数据。所有收益率、卖出价和买入价都按不同工作表的顺序排序。我想为每只债券获得一张新的表格，其中包含相应的收益率、买入价和卖出价。我的收益率在表 2 中，卖出价在表 3 中，买入价在表 4 中。它应该总是复制两整列，因此例如对于第一个债券，它应该复制表 2 的前两列(两列，因为一列是收益率，一列是日期)，表 3 的前 2 列和工作表 4 的前两列，并将它们并排放置在新工作表中， 对于下一个债券，它应该复制每张纸的下两列，并将其复制到新一张纸中，依此类推。是否有可能编写宏来执行此操作？

以下是我为前两个债券手动执行的宏的记录

ActiveCell.Offset(0, -6).Columns("A:B").EntireColumn.Select
ActiveCell.Offset(0, -6).Range("A1").Activate
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Sheets("Sheet3").Select
ActiveCell.Columns("A:B").EntireColumn.Select
ActiveCell.Offset(1, 0).Range("A1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet7").Select
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
ActiveCell.Columns("A:B").EntireColumn.Select
ActiveCell.Offset(1, 0).Range("A1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet7").Select
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Paste
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
ActiveCell.Offset(0, 2).Columns("A:B").EntireColumn.Select
ActiveCell.Offset(0, 2).Range("A1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet8").Select
ActiveSheet.Paste
Sheets("Sheet3").Select
ActiveCell.Offset(0, 2).Range("A1:B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Ask Close"
ActiveCell.Columns("A:B").EntireColumn.Select
ActiveCell.Activate
Selection.Copy
Sheets("Sheet8").Select
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
ActiveCell.Offset(0, 2).Columns("A:B").EntireColumn.Select
ActiveCell.Offset(0, 2).Range("A1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet8").Select
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Paste

Answer 1

只要您的工作表都具有默认名称，这应该可以执行您想要的操作。

Option Explicit
Sub copyColtoSheet()
Dim pasteSheet As Worksheet
Dim copySheet As Worksheet
Dim i As Integer
'Create new sheet to paste column data to
With ThisWorkbook
.Sheets.Add After:=.Sheets(.Sheets.Count)
Set pasteSheet = .Worksheets("Sheet" & .Sheets.Count)
End With
'Copy Sheet columns to new sheet
Dim pasteColumn As Integer
pasteColumn = 1
For i = 2 To 4
With pasteSheet
Dim allRows As Integer
Set copySheet = ThisWorkbook.Worksheets("Sheet" & i)
allRows = copySheet.Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Range(.Cells(1, pasteColumn), .Cells(allRows, pasteColumn)), .Range(.Cells(1, pasteColumn + 1), .Cells(allRows, pasteColumn + 1))).Value = copySheet.Range("A:B").Value
pasteColumn = pasteColumn + 2
End With
Next i
End Sub

我已经测试了这段代码，它可以工作。