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

VBA - 跨多个表格重新排列列顺序

1 个答案: