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

【问题标题】：Show columns placed in multiple ranges显示放置在多个范围内的列
【发布时间】：2015-03-24 21:16:36
【问题描述】：

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

每个文件都有完全相同的列（Apples、Oranges、Bananas 等），但在整个工作表中放置在不同的字母下。例如，“Apples”列在前 5 张表中的字母 A 下，但在其余表中位于字母 C 下。这个顺序并不一致，并且在每个文件中有所不同。

我想要一个能够：

解开所有工作表中的所有单元格。
隐藏所有工作表中从 A 到 Z 的列。
仅取消隐藏第 1 行中包含“apples/apple”、“oranges/orange”和“bananas/bananas”字样的三列。
缩小以适合“apples/apple”列中的文本并将宽度设置为 120。
换行以适合“oranges/orange”和“bananas/bananas”列上的文本，并将宽度设置为 350。
将所有工作表缩放到 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

【问题讨论】：

试图解码你的模块...下面的代码应该完成什么：c = wsh.Cells.Find(What:="*",?
您想要提示作为工作簿的每张工作表，还是想要宏“记住”什么是 Area(1)、Area(2) 和 Area(3) 并自动调整大小它们在随后的工作表中？
感谢 Micheal 的快速回答和代码。事实上，我还注意到标题实际上并不一致，例如有时是 apple 而其他时候是 apples。是否可以在这 3 列的标题中指示要查找的文本，而不是手动选择它们？这样，将显示包括“apple”或“apples”在内的所有列。谢谢
您是否因为列不匹配而出现运行时错误？
如果在后续工作表中未准确找到列名，则添加一个新弹出窗口。因此，如果您在第一个和第二个工作表中有 apple 而在第三个工作表中有 apples，当代码循环到第三个工作表时，您将收到第二个 InputBox 并且它无法准确找到 apples。

标签： vba excel

【解决方案1】：

如果您只是想要一个弹出框让用户选择每张纸上的 3 列，请删除显示为的行

f = True

在If f = False Then 语句中。

如果您希望宏“记住”第一页上选择的每一列的列标题，那么您需要稍微修改代码（并做出一些假设）：

假设

列标题在第一行
列标题是唯一的（即，您不会在同一张工作表中多次使用相同的列标题）。

编辑：代码现在会将所有选定的列存储在一个数组中，该数组将在每个工作表上进行搜索。例如，如果在工作表 1 上您有 apple、banana 和 coconut，您将得到一个初始的 InputBox。如果在工作表 3 上，您现在有 apples、bananas 和 coconuts，那么您将收到第二个 InputBox 询问这些值。现在，在工作表 4-n 上，代码将搜索 either 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

【讨论】：