Show columns placed in multiple ranges - vba

Question

I have multiple Excel files with the following structure:
Each file has the exact same columns (Apples, Oranges, Bananas, etc.) but placed under different letters throughout the sheets. For example, column "Apples" is under letter A in the first 5 sheets, but it's under letter C in the rest of the sheets. This order is not consistent and varies in each file.
I would like a macro capable of:
Unwrap all the cells in all sheets.
Hide columns from A to Z in all sheets.
Unhide only three columns featuring the words "apples/apple", "oranges/orange" and "bananas/bananas" in row 1.
Shrink to fit the text in the "apples/apple" column and set the width to 120.
Wrap to fit the text on the "oranges/orange" and "bananas/bananas" columns and set the width to 350.
Zoom all sheets to 100%.
I have this macro that works like a charm, as it allows me to choose which three columns I want to keep. However, it works exclusively if they are placed in the exact same order in all sheets:
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
EDIT: I've also this code, which is significantly lighter (even though doesn't quite perform all tasks I wanted) but for some reasons works only with a single file and not when assigned to my Personal.xls sheet.
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

If you simply want a popup box for the user to select the 3 columns on each sheet, remove the line that reads
f = True
that is inside the If f = False Then statement.
If you want the macro to "remember" the column headers for each column chosen on the first page, then you'll need to modify the code slightly (and make some assumptions):
Assumptions
The column headers are in the first row
The column headers are unique (i.e., you don't have the same column title multiple times in the same sheet).
EDIT:
Code will now store all selected columns in an array that will search on each worksheet. For example, if on worksheet 1 you have apple, banana, and coconut, you will get an initial InputBox. If on worksheet 3, you now have apples, bananas, and coconuts, then you will get a second InputBox asking for these values. Now, on worksheets 4-n, the code will search for either apple or apples.
Code
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