Vba 显示放置在多个范围中的列_Vba_Excel

Vba 显示放置在多个范围中的列

vba excel

Vba 显示放置在多个范围中的列,vba,excel,Vba,Excel,我有多个Excel文件，其结构如下：每个文件都有完全相同的列（苹果、桔子、香蕉等），但在整个表格中放置在不同的字母下。例如，“苹果”列在前5页的字母A下，但在其余页的字母C下。此顺序不一致，并且在每个文件中有所不同我想要一个能够：展开所有工作表中的所有单元格在所有图纸中从A到Z隐藏列仅取消隐藏第1行中“苹果/苹果”、“橙子/橙子”和“香蕉/香蕉”三列收缩以适合“apples/apple”列中的文本，并将宽度设置为120 包裹以适合“oranges/orange”和“bananas/b

我有多个Excel文件，其结构如下：

每个文件都有完全相同的列（苹果、桔子、香蕉等），但在整个表格中放置在不同的字母下。例如，“苹果”列在前5页的字母A下，但在其余页的字母C下。此顺序不一致，并且在每个文件中有所不同

我想要一个能够：

展开所有工作表中的所有单元格

在所有图纸中从A到Z隐藏列

仅取消隐藏第1行中“苹果/苹果”、“橙子/橙子”和“香蕉/香蕉”三列

收缩以适合“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

如果您只是想要一个弹出框供用户选择每张图纸上的3列，请删除以下行

f = True

这在

语句中，如果f=False，则为语句
如果希望宏“记住”在第一页上选择的每个列的列标题，则需要稍微修改代码（并做出一些假设）：
假设
列标题位于第一行
列标题是唯一的（即，在同一工作表中，您没有多次使用相同的列标题）
编辑：
代码现在将所有选定列存储在一个数组中，该数组将在每个工作表上搜索。例如，如果在工作表1中有苹果、香蕉和椰子，您将得到一个初始的输入框
。如果在工作表3中，您现在有苹果、香蕉和椰子，则您将获得第二个输入框
，询问这些值。现在，在工作表4-n上，代码将搜索苹果或苹果
代码
正在尝试解码您的模块…以下代码应该完成什么：c=wsh.Cells.Find（what:=“*”，
？您希望工作簿中的每张工作表都有提示，还是希望宏“记住”哪个区域（1）、区域（2）和区域（3）是否在后续的工作表中自动调整大小？感谢Micheal的快速回答和代码。事实上，我还注意到标题实际上不一致，有时是apple，有时是apple。是否可以在这3列的标题中指示要查找的文本，而不是of手动选择？这样，所有列包括“苹果”或“苹果”将显示。谢谢您是否因为列不匹配而收到运行时错误？如果在后续工作表中找不到正确的列名，则会添加一个新的弹出窗口。因此，如果第一个和第二个工作表中有apple，但第三个工作表中有apple，则当代码循环到第三个工作表时，您将收到第二个输入框它不能准确地找到苹果。
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