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

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

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