放置在多個範圍

展列我有多個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

放置在多個範圍

回答

相關問題