放置在多个范围

展列我有多个Excel文件的结构如下：放置在多个范围

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

我想宏能够：

展开所有小区中的所有片。
在所有工作表中隐藏从A到Z的列。
取消隐藏第1行仅显示了“苹果/苹果”，“橙子/桔子”和“香蕉/香蕉”等字样的三列。
缩小以适合“苹果/苹果”列中的文字并设置宽度设置为120.
将文本放在“桔子/桔子”和“香蕉/香蕉”列中，并将宽度设置为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

来源

2015-03-24 Marrone

试图解码你的模块...什么是应该完成下面的代码：'C = wsh.Cells.Find（什么：？= “*”，' – Michael 2015-03-24 21:27:23

你想为每一个工作簿或做你所需的宏“记住”片提示什么区（1），区（2）和面积（3），并自动调整它们在随后的表？ – Michael 2015-03-24 21:32:42

感谢迈克尔您的快速回答和你的代码。事实是，我也注意到，头其实并不一致，因为有时是** **苹果和其他一些时候是** **苹果例如，是否可以来表示文字在这3列的标题中查找而不是手动选择它们？这样，所有列，包括“苹果”或“苹果”将被显示。谢谢 – Marrone 2015-03-25 18:40:00

如果你只是想为用户选择3列在每张纸上，除去读

f = True

那就是If f = False Then语句中的线弹出框。

如果你想宏“记住”为选择的第一页上的每个列的列标题，那么你就需要修改轻微的代码（和做一些假设）：

假设

列标题在第一行
列标题是唯一的（即，您在同一张表中没有多次具有相同的列标题）。

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

代码

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

来源

2015-03-24 22:07:07 Michael

放置在多个范围

回答

相关问题