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