显示放置在多个范围内的列

Question

我有多个具有以下结构的Excel文件：

每个文件都有完全相同的列（苹果，橘子，香蕉等），但在整个工作表中放置不同的字母。例如，“Apples”列在前5页中位于字母A下，但在其余页面中位于字母C下方。此订单不一致，并且在每个文件中都有所不同。

我想要一个能够：

的宏

1. 打开所有床单中的所有单元格。
2. 在所有工作表中隐藏A到Z的列。
3. 在第1行中取消隐藏三栏，其中包含“苹果/苹果”，“橙子/橙子”和“香蕉/香蕉”字样。
4. 缩小以适合“apples / apple”列中的文本，并将宽度设置为120。
5. 换上“橙子/橙子”和“香蕉/香蕉”栏中的文字并将宽度设置为350.
6. 将所有工作表缩放至100％。

我有一个像魅力一样的宏，因为它允许我选择我想要保留的三列。但是，如果它们在所有工作表中以完全相同的顺序放置，则它可以专门工作：

Sub AdjustTF()
ColumnWidth = 10
ActiveWindow.Zoom = 100
Dim wsh As Worksheet
Dim rng As Range
Dim i As Long
Dim f As Boolean
Dim c As Long
On Error GoTo ErrHandler
' The following two lines are optional
Worksheets(1).Select
Range("A1").Select
For Each wsh In Worksheets
    wsh.Cells.WrapText = False
    wsh.Cells.VerticalAlignment = xlBottom
    wsh.Cells.HorizontalAlignment = xlLeft
    wsh.Cells.EntireColumn.Hidden = False
    If f = False Then
        Set rng = Application.InputBox( _
            Prompt:="Select the columns to keep.", _
            Type:=8).EntireColumn
        f = True
    End If
    Set rng = wsh.Range(rng.Address).EntireColumn
    c = wsh.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious).Column
    wsh.Range(wsh.Cells(1, 1), wsh.Cells(1, c)).EntireColumn.Hidden = True
    With rng
        .Hidden = False
        With .Areas(1)
            .ColumnWidth = 3
            For i = 1 To 3
                .ColumnWidth = 120 / .Width * .ColumnWidth
            Next i
            .ShrinkToFit = True
        End With
        With .Areas(2)
            .ColumnWidth = 8
            For i = 1 To 3
                .ColumnWidth = 350 / .Width * .ColumnWidth
            Next i
            .WrapText = True
        End With
        With .Areas(3)
            .ColumnWidth = 8
            For i = 1 To 3
                .ColumnWidth = 350 / .Width * .ColumnWidth
            Next i
            .WrapText = True
        End With
    End With
    wsh.Cells.EntireRow.AutoFit
NextSheet:
    Next wsh
    Application.Goto Worksheets(1).Range("A1"), True
    Exit Sub
ErrHandler:
    Select Case Err
        Case 424 ' Object required
            Resume NextSheet
        Case Else
            MsgBox Err.Description, vbExclamation
    End Select
End Sub

编辑：我还有这个代码，它明显更轻（尽管不能完全执行我想要的所有任务）但由于某些原因只适用于单个文件而不是分配时到我的Personal.xls表。

Sub AdjustTFAlternate()
  Dim R As Range
  Dim Ws As Worksheet
  Dim Item
  'In each worksheet
  For Each Ws In ActiveWorkbook.Worksheets
    'Hide all columns
    Ws.UsedRange.EntireColumn.Hidden = True
    'Search for this words
    For Each Item In Array("apple*", "orange*", "banana*")
      'Search for a keyword in the 1st row
      Set R = Ws.Rows(1).Find(Item, LookIn:=xlFormulas, LookAt:=xlWhole)
      If R Is Nothing Then
        'Not found
        Exit For
      End If
      'Unhide this column
      R.EntireColumn.Hidden = False
    Next
  Next
End Sub

Answer 1

如果您只是想让用户在弹出框中选择每张纸上的3列，请删除读取的行

f = True

位于If f = False Then语句中。

如果您希望宏能够记住＆＃34;在第一页上选择的每个列的列标题，然后您需要稍微修改代码（并做出一些假设）：

假设

1. 列标题位于第一行
2. 列标题是唯一的（即，您不会在同一张表中多次使用相同的列标题）。

编辑： 代码现在将所有选定列存储在将在每个工作表上搜索的数组中。例如，如果在工作表1中有 apple ，香蕉和椰子，则会得到一个初始InputBox。如果在工作表3上，您现在有苹果，香蕉和椰子，那么您将获得第二个InputBox请求这些值。现在，在工作表4-n上，代码将搜索 apple 或 apples 。

代码

Sub AdjustTF()
ColumnWidth = 10
Dim wsh As Worksheet
Dim rng As Range
Dim i As Long
Dim f As Boolean
Dim c As Long

'Dim aCol(1 To 1, 1 To 3) As String
Dim aCol() As String
    ReDim aCol(1 To 3, 1 To 1)
Dim iCol(1 To 3) As Integer
Dim iTemp As Integer
Dim uStr As String

On Error GoTo ErrHandler
' The following two lines are optional
Worksheets(1).Select
Range("A1").Select
For Each wsh In Worksheets
    d = 1
    wsh.Cells.WrapText = False
    wsh.Cells.VerticalAlignment = xlBottom
    wsh.Cells.HorizontalAlignment = xlLeft
    wsh.Cells.EntireColumn.Hidden = False
    If f = False Then
        On Error Resume Next
            Err.Number = 0
            Set rng = Application.InputBox( _
                Prompt:="Select the columns to keep.", _
                Type:=8).EntireColumn
            If Err.Number > 0 Then
                Exit Sub
            End If
        On Error GoTo ErrHandler

        f = True
        aCol(1, 1) = wsh.Cells(1, rng.Areas(1).Column).Value
        aCol(2, 1) = wsh.Cells(1, rng.Areas(2).Column).Value
        aCol(3, 1) = wsh.Cells(1, rng.Areas(3).Column).Value

    Else
        On Error Resume Next
            For a = 1 To 3
                iCol(a) = 0
            Next
            For a = 1 To UBound(aCol, 2)
                Err.Number = 0
                iTemp = wsh.Cells.Find(what:=aCol(1, a), lookat:=xlWhole).Column
                    If Err.Number = 0 And iCol(1) = 0 Then iCol(1) = iTemp
                Err.Number = 0
                iTemp = wsh.Cells.Find(what:=aCol(2, a), lookat:=xlWhole).Column
                    If Err.Number = 0 And iCol(2) = 0 Then iCol(2) = iTemp
                Err.Number = 0
                iTemp = wsh.Cells.Find(what:=aCol(3, a), lookat:=xlWhole).Column
                    If Err.Number = 0 And iCol(3) = 0 Then iCol(3) = iTemp

                If iCol(1) > 0 And iCol(2) > 0 And iCol(3) > 0 Then Exit For
            Next
            If iCol(1) = 0 Or iCol(2) = 0 Or iCol(3) = 0 Then
                wsh.Activate
                    Err.Number = 0
                    Set rng = Application.InputBox( _
                        Prompt:="Select the columns to keep.", _
                        Type:=8).EntireColumn
                    If Err.Number > 0 Then
                        Exit Sub
                    End If


                a = UBound(aCol, 2) + 1
                ReDim Preserve aCol(1 To 3, 1 To a)
                aCol(1, a) = wsh.Cells(1, rng.Areas(1).Column).Value
                aCol(2, a) = wsh.Cells(1, rng.Areas(2).Column).Value
                aCol(3, a) = wsh.Cells(1, rng.Areas(3).Column).Value

            Else
                uStr = Range(wsh.Cells(1, iCol(1)), wsh.Cells(1, iCol(1))).Address & "," & _
                    Range(wsh.Cells(1, iCol(2)), wsh.Cells(1, iCol(2))).Address & "," & _
                    Range(wsh.Cells(1, iCol(3)), wsh.Cells(1, iCol(3))).Address


                Set rng = Range(uStr)
            End If
        On Error GoTo ErrHandler
    End If

    Set rng = wsh.Range(rng.Address).EntireColumn


    c = wsh.Cells.Find(what:="*", SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious).Column
    wsh.Range(wsh.Cells(1, 1), wsh.Cells(1, c)).EntireColumn.Hidden = True
    With rng
        .Hidden = False
        With .Areas(1)
            .ColumnWidth = 3
            For i = 1 To 3
                .ColumnWidth = 120 / .Width * .ColumnWidth
            Next i
            .ShrinkToFit = True
        End With
        With .Areas(2)
            .ColumnWidth = 8
            For i = 1 To 3
                .ColumnWidth = 350 / .Width * .ColumnWidth
            Next i
            .WrapText = True
        End With
        With .Areas(3)
            .ColumnWidth = 8
            For i = 1 To 3
                .ColumnWidth = 350 / .Width * .ColumnWidth
            Next i
            .WrapText = True
        End With
    End With
    wsh.Cells.EntireRow.AutoFit
    wsh.Activate
    ActiveWindow.Zoom = 100
    wsh.Cells(1, 1).Select
NextSheet:
    Next wsh
    Application.Goto Worksheets(1).Range("A1"), True
    Exit Sub
ErrHandler:
    Select Case Err
        Case 424 ' Object required
            Resume NextSheet
        Case Else
            MsgBox Err.Description, vbExclamation
    End Select
End Sub