与“选择案例”相结合的循环

Posted 2023-02-19

【中文标题】与“选择案例”相结合的循环

【英文标题】：Loop with "Select Cases" combined

【发布时间】：2016-01-19 02:33:02

【问题描述】：

我尝试组合一个简单的循环代码并选择案例以返回所需的用户结果（我知道代码不正确）。在 J 列中，我有从 2012 年到 2017 年的一系列年份，具体取决于 J 列中的年份，我希望将 U 列中的数据剪切到 AG 并将其粘贴到正确的位置。

我想出的代码如下；

Sub Move_data()

Dim rng As Range
Dim LR As Long
LR = Range("J1048576").End(xlUp).Row
Set rng = Range(Cells(2, 10), Cells((LR), 10))

For x = 2 To LR Step 1
Select Case Range("J" & x).Value2
        Case 2012
            Range("BU" & x).Cut
            Range("IH" & x).Paste
            Range("U" & x, ":CG" & x).Cut
            Range("AH" & x).PasteSpecial
            ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
        Case 2013
            Range("BU" & x).Cut
            Range("IH" & x).Paste
            Range("U" & x, ":CG" & x).Cut
            Range("AU" & x).PasteSpecial
            ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
        Case 2014
            Range("BU" & x).Cut
            Range("IH" & x).Paste
            Range("U" & x, ":CG" & x).Cut
            Range("BH" & x).PasteSpecial
            ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
        Case 2015
            Range("BU" & x).Cut
            Range("IH" & x).Paste
            Range("U" & x, ":CG" & x).Cut
            Range("BU" & x).PasteSpecial
            ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
        Case 2016
            Range("BU" & x).Cut
            Range("IH" & x).Paste
            Range("U" & x, ":CG" & x).Cut
            Range("CH" & x).PasteSpecial
            ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
        Case 2017
            Range("BU" & x).Cut
            Range("IH" & x).Paste
            Range("U" & x, ":CG" & x).Cut
            Range("CU" & x).PasteSpecial
            ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

           End Select

             x = x + 1
            Else
            End If
            Next x


            End Sub

另外我觉得循环遍历每一行可能没有时间效率，因为文件中有超过 1000 行，排序和选择所有相同的年份并一次移动所有数据可能会更快。 （但我不确定如何做到这一点）

非常感谢任何有关代码调整的帮助或实现此目标的最佳方法的指导！我附上了一张图片，以指导我想要实现的目标。

【参考方案1】：

虽然这不能完全满足您的需求，但它会让您了解如何开始使用表格。这将检测表中的唯一值（而不是设置案例示例），然后尝试跟踪它。您必须将数据源转换为表格 (listobject)，还有一些其他内容需要修改（尝试使用 cmets 突出显示它们。查看代码并随时提问有用的话有什么问题。

数据源（表格）

代码

Option Explicit

Sub tableLoop()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim i As Integer: Dim NoRow As Integer
    Dim arr() As Variant
    Dim c

    With Application
        .ScreenUpdating = False
    End With

    Set ws = ActiveSheet
    Set tbl = ws.ListObjects(1)

    On Error Resume Next
    ws.ShowAllData
    On Error GoTo 0

    ' first we will sort the table into order on year
    With tbl.Sort
        .SortFields.Clear
        ' Change the Range to match your table and year column)
        .SortFields.Add Key:=Range("Table1[[#All],[Project Year]]"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' Get unique values in project year and put into array

    With tbl.ListColumns(1).DataBodyRange
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    End With
    i = 0
    For Each c In tbl.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
        ReDim Preserve arr(0 To i)
        arr(i) = c.Value
        i = i + 1
    Next c

    ' Change this loop for however you want the output to be
    For i = 1 To UBound(arr)
        Debug.Print arr(i)
        With tbl
            .Range.AutoFilter Field:=1, Criteria1:=arr(i)
            .ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
        End With
        With ws
            NoRow = i
            .Cells(NoRow, 5) = arr(i)
            .Cells(NoRow, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            On Error Resume Next
            .ShowAllData
            On Error GoTo 0
        End With
    Next i

    With Application
        .ScreenUpdating = True
    End With

End Sub

输出

【参考方案2】：

在我匆忙查看您的代码时，似乎只有 Range(...).PasteSpecial 行在不同情况下有所不同。您可以消除Select Case 结构，而是创建一个包含PasteSpecial 列的数组：cols = "AH", "AU", "BH", "BU", "CH", "CU"。然后你可以选择TheCol = cols(year-2011)的列。

另一种方式：由于列是规则间隔的（相隔 13），您可以按列号：col_num = 13*(year-2011) + 21。然后使用Range.Cells(x, col_num)之类的东西。

希望有帮助