如果值不在數組中，則刪除基於列

Question

我有一個財務模型，我只想在新工作簿中復制和粘貼 3 個工作表的值。 該模型在第 7 行有 FY17 至 FY28，我只想保留 FY17 至 FY21。 任何與 FY17 至 FY21 不匹配的非空白單元格，我想刪除整列。

問題是代碼跳過了列，我不知道如何使用“.xl last column end”來修復它。 我不認為同樣的邏輯適用於列，因為它適用於行。 我只想刪除 worksheet1 和 worksheet2 的列。

此外，如果您可以將delete range部分合並為一個部分，那就太好了。 我嘗試使用與復制相同的array函數，但顯然，它不適用於刪除？

謝謝你。

Sub CopyPasteValues()

    Dim ws As Worksheet
    Dim strSaveName As String
    Dim cell As Range
    Dim arr
    Dim deleteRange As Range

    'Name of new workbook
    strSaveName = ActiveWorkbook.Name & " VALUES.xlsx"

    'Copy the 3 sheets into new workbook
    ActiveWorkbook.Sheets(Array("worksheet1", "worksheet2", "worksheet3")).Copy

    'Copy and paste values
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Visible = True Then
            With ws
                .Activate
                .Cells.Copy
                .Range("A1").PasteSpecial Paste:=xlValues
            End With
        End If
    Next ws

    'Deleting column except FY17, FY18, FY19, FY20, FY21

    Set deleteRange = Range("F7:FP7")
    arr = Array("FY17", "FY18", "FY19", "FY20", "FY21")

    For Each cell In ActiveWorkbook.Worksheets("worksheet1").Range("F7:FP7")
        If IsError(Application.Match(cell.Value, arr, 0)) Then
            cell.EntireColumn.Delete
        End If
    Next

    For Each cell In ActiveWorkbook.Worksheets("worksheet2").Range("F7:FP7")
        If IsError(Application.Match(cell.Value, arr, 0)) Then
            cell.EntireColumn.Delete
        End If
    Next

    ActiveWorkbook.SaveAs "C:\Users\..." & strSaveName, FileFormat:=51

End Sub

Answer 1

For Each Loop 在這種情況下不能很好地工作，因為您正在從集合中刪除列。

當您刪除 Col F 時，您的范圍將向左移動，Col G 數據將在 Col F 中。這使得代碼不可靠。

下面不是 For Each 方法，而是基於列號工作，該列號從 Col FP 開始循環到更一致的 F。 此外，我為再次循環的工作表創建了一個數組。

 Sub CopyPasteValues()

    Dim ws As Worksheet, objWksht As Worksheet
    Dim strSaveName As String
    Dim cell As Range
    Dim arr, ShtArr, Shtloop

    'Name of new workbook
    strSaveName = ActiveWorkbook.Name & " VALUES.xlsx"

    'Copy the 3 sheets into new workbook
    ActiveWorkbook.Sheets(Array("worksheet1", "worksheet2", "worksheet3")).Copy

    'Copy and paste values
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Visible = True Then
            With ws
                .Activate
                .Cells.Copy
                .Range("A1").PasteSpecial Paste:=xlValues
            End With
        End If
    Next ws

    'Deleting column except FY17, FY18, FY19, FY20, FY21

    arr = Array("FY17", "FY18", "FY19", "FY20", "FY21")
    ShtArr = Array("worksheet1", "worksheet2")

    For Shtloop = LBound(ShtArr) To Ubount(ShtArr)
        Set objWksht = ActiveWorkbook.Worksheets(ShtArr(Shtloop)) 'loops the worksheet
            '172 Refers to Column FP; 6 refers to Column F
        For ColNumb = 172 To 6 Step -1
            If IsError(Application.Match(objWksht.Cells(7, ColNumb).Value, arr, 0)) Then
                objWksht.Cells(7, ColNumb).EntireColumn.Delete
            End If
        Next ColNumb
    Next Shtloop

    ActiveWorkbook.SaveAs "C:\Users\..." & strSaveName, FileFormat:=51

End Sub

希望這可以幫助。 祝你好運。