我需要为唯一输出创建一个循环，该输出被复制到同一工作表中的不同列

Question

我有以下代码：

Private Sub Unique_Click()
Dim xRng As Range
Dim xLastRow As Long
Dim xLastRow2 As Long
Dim i As Integer
On Error Resume Next
Set xRng = Worksheets("Data1").Range(Range("C15"))
If xRng Is Nothing Then Exit Sub
On Error Resume Next
xRng.Copy Range("B21")
xLastRow = xRng.Rows.Count + 1
ActiveSheet.Range("B21:B" & xLastRow).RemoveDuplicates Columns:=1, Header:=xlNo
Set xRng = Worksheets("Data2").Range(Range("O15"))
If xRng Is Nothing Then Exit Sub
On Error Resume Next
xRng.Copy Range("N21")
xLastRow = xRng.Rows.Count + 1
ActiveSheet.Range("N21:N" & xLastRow).RemoveDuplicates Columns:=1, Header:=xlNo
Set xRng = Worksheets("Data3").Range(Range("AA15"))
If xRng Is Nothing Then Exit Sub
On Error Resume Next
xRng.Copy Range("Z21")
xLastRow = xRng.Rows.Count + 1
ActiveSheet.Range("Z21:Z" & xLastRow).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

我需要循环这个。或者，我必须重复 31 次(一个月内最多天数(。输出列之间的间距始终相同。即B21，N21之间的区别;Z21等

有什么建议吗？否则我只会手动完成。

Answer 1

也许这样的事情会有所帮助：

Private Sub Unique_Click()
    Dim xRng As Range
    Dim xLastRow As Long
    Dim xLastRow2 As Long
    Dim i As Integer
    Dim colNo As Integer
    On Error Resume Next
    For colNo = 3 To 27 Step 12
        Set xRng = Worksheets("Data1").Cells(15, colNo)
        If xRng Is Nothing Then Exit Sub
        xRng.Copy Cells(21, colNo - 1)
        xLastRow = xRng.Rows.Count + 1
        ActiveSheet.Range(Cells(21, colNo - 1), Cells(xLastRow, colNo - 1)).RemoveDuplicates Columns:=1, Header:=xlNo
    Next colNo
End Sub

您只需要遍历 ColNo(步骤 = 12，这意味着我们在每个循环中添加 12 列(，从 C 列 (3( 开始，到 AA 列 (27( 结束。

我还建议在xRng.Copy Cells(21, colNo - 1)中添加工作表名称，以确保代码在正确的位置运行。

还有一个提示 - 你不需要使用On Error Resume Next很多次。它保持活动状态，直到您用On Error GoTo 0"关闭它"。

希望对您有所帮助。