VBA-在多張圖紙上重新排列列順序

Question

我有2個巨集

1）刪除我的數組中未指定的列（基於列標題）

這是代碼：

Sub testDelete()

Dim currentColumn As Integer
    Dim columnHeading As String
    Dim ws1 As Worksheet

    Set ws1 = ActiveWorkbook.Sheets("mySheet")

ws1.Activate

    With ws1

    For currentColumn = ws1.UsedRange.Columns.Count To 1 Step -1

        columnHeading = ws1.UsedRange.Cells(1, currentColumn).Value

        'CHECK WHETHER TO KEEP THE COLUMN
        Select Case columnHeading
            Case "Employee Number", "Status"
                'Do nothing
            Case Else

                    ws1.Columns(currentColumn).Delete

        End Select
    Next

    End With

End Sub

2）對特定工作表上的列重新排序，並刪除我未在數組中指定的任何列。

這是代碼：

Sub testReorder()

    Dim arrColOrder As Variant, ndx As Integer
    Dim Found As Range, Counter As Integer
    Dim ws1 As Worksheet
    Set ws1 = ActiveWorkbook.Sheets("mySheet")

    ws1.Activate

    arrColOrder = Array("Employee Number", "Status")

    'Copy and Paste Sheet as Values
    ws1.Cells.Copy
    ws1.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    With ws1

        Counter = 1

        Application.ScreenUpdating = False

        For ndx = LBound(arrColOrder) To UBound(arrColOrder)

            Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, Lookat:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

            If Not Found Is Nothing Then
                If Found.Column <> Counter Then
                    Found.EntireColumn.Cut
                    Columns(Counter).Insert Shift:=xlToRight
                    Application.CutCopyMode = False
                End If
                Counter = Counter + 1
            End If
        Next ndx

        ws1.Range("K:M").EntireColumn.Delete

        Application.ScreenUpdating = True

    End With

End Sub

當前，這些宏僅適用於一張紙，但是，當有50張紙時，為每張紙命名是不現實的。

大多數工作表將具有兩個列標題： 員工編號和狀態，而有些僅具有員工編號

我想要做的是將這些宏合並為一個宏，並使其可以用於工作簿中的所有工作表，而不僅僅是一個工作表。

這是我到目前為止所擁有的：

Sub testNew()

    Dim Found As Range, Counter As Integer, ndx As Integer, currentColumn As Integer
    Dim columnHeading As String
    Dim arrColOrder As Variant

    arrColOrder = Array("Employee Number", "Status")

    'Copy and Paste Sheet as Values
    ActiveWorkbook.Sheets(1).Cells.Copy
    ActiveWorkbook.Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    For currentColumn = ActiveWorkbook.Sheets(1).UsedRange.Columns.count To 1 Step -1

        columnHeading = ActiveWorkbook.Sheets(1).UsedRange.Cells(1, currentColumn).Value

        'CHECK WHETHER TO KEEP THE COLUMN
        Select Case columnHeading
            Case "Employee Number", "Status"
                'Do nothing
            Case Else

                    ActiveWorkbook.Sheets(1).Columns(currentColumn).Delete

        End Select
    Next

    Counter = 1

    Application.ScreenUpdating = False

    For ndx = LBound(arrColOrder) To UBound(arrColOrder)

            Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, Lookat:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

            If Not Found Is Nothing Then
                If Found.Column <> Counter Then
                    Found.EntireColumn.Cut
                    Columns(Counter).Insert Shift:=xlToRight
                    Application.CutCopyMode = False
                End If
                Counter = Counter + 1
            End If
        Next ndx

        Application.ScreenUpdating = True

    End With

End Sub

Answer 1

我設法找到了解決我問題的方法。

這是代碼：

Sub ManipulateSheets()

    Dim ws1 As Worksheet
    Dim a As Long, w As Long
    Dim keepCols As Variant

    Set wkbk1 = Workbooks("3rd Party.xlsm")

    keepCols = Array("Employee Number", "Status")

    wkbk1.Activate

    For Each ws1 In wkbk1.Sheets

        ws1.Cells(1, 1).EntireRow.Replace What:="USERID", Replacement:="Employee Number", Lookat:=xlWhole
        ws1.Cells(1, 1).EntireRow.Replace What:="STATUS", Replacement:="Status", Lookat:=xlWhole
        ws1.Cells(1, 1).EntireRow.Replace What:="USER_ID", Replacement:="Employee Number", Lookat:=xlWhole
        ws1.Cells(1, 1).EntireRow.Replace What:="USER_STATUS", Replacement:="Status", Lookat:=xlWhole
        ws1.Cells(1, 1).EntireRow.Replace What:="HR_STATUS", Replacement:="Status", Lookat:=xlWhole

    Next ws1

    With wkbk1

        For w = 1 To .Worksheets.count

            With Worksheets(w)

                For a = .Columns.count To 1 Step -1

                    If UBound(Filter(keepCols, .Cells(1, a), True, vbTextCompare)) < 0 Then _
                            .Columns(a).EntireColumn.Delete

                Next a

            End With

        Next w

    End With

End Sub