Advanced Filter - exclude headers - excel

I have a macro that does an Advanced Filter. How can I exclude the headers from this? I tried changing C:C to C2:C but it's not working.
Sub extractuniquevalues2()
Dim wks As Excel.Worksheet
Dim wksSummary As Excel.Worksheet
'----------------------------------------------------------------------------------
'edited so it shows in the 3rd column row +1. Add the header and sheet name macro to this
On Error Resume Next
Set wksSummary = Excel.ThisWorkbook.Worksheets("Unique data")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = Excel.ThisWorkbook.Worksheets.Add
wksSummary.Name = "Unique data"
End If
'Iterate through all the worksheets, but skip [Summary] worksheet.
For Each wks In Excel.ActiveWorkbook.Worksheets
With wksSummary
If wks.Name <> .Name Then
If Application.WorksheetFunction.CountA(wks.Range("C:C")) Then
Call wks.Range("C:C").AdvancedFilter(xlFilterCopy, , .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row + 1, 3), True)
End If
End If
End With
Next wks
End Sub
To show you a visual check my image: [img]http://i.imgur.com/xGcAZMj.jpg[/img]
Would like to get rid of the headers and have the names row-by-row without spaces between.
EDIT------------------------------------------------------------------------
So i'm doing it like so, getting errors:
Sub testage()
Dim wks As Excel.Worksheet
Dim wksSummary As Excel.Worksheet
'----------------------------------------------------------------------------------
'edited so it shows in the 3rd column row +1. Add the header and sheet name macro to this
On Error Resume Next
Set wksSummary = Excel.ThisWorkbook.Worksheets("Unique data")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = Excel.ThisWorkbook.Worksheets.Add
wksSummary.Name = "Unique data"
End If
'Iterate through all the worksheets, but skip [Summary] worksheet.
For Each wks In Excel.ActiveWorkbook.Worksheets
Dim r As Range
' Get the first cell of our destination range...
Set r = .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row + 1, 3)
' Perform the unique copy...
wks.Range("C:C").AdvancedFilter xlFilterCopy, , r, True
'Remove the first cell at the destination range...
r.Delete xlShiftUp
Next wks
End Sub

Unfortunately, no. All of the filter functions work with headers, even the ones where you copy to a new destination, such as in your case. But you can just follow-up with a Delete xlShiftUp to remove the first cell at your destination range and shift everything up a spot:
Dim r As Range
' Get the first cell of our destination range...
Set r = .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row + 1, 3)
' Perform the unique copy...
wks.Range("C:C").AdvancedFilter xlFilterCopy, , r, True
' Remove the first cell at the destination range...
r.Delete xlShiftUp

Related

EXCEL: How to combine values from two different column into one new column on different sheet

i am stuck with my procject again... I tried with formulas but i can t make it work or i can t make it right, and i couldn t find similar topic any where, here is the problem. As u can see in screenshot in this link https://ibb.co/FJRBxcM i have 2 worksheets, Sheet1 with some value generator, and Sheet"RadniNalog" where i copy&paste manualy certan values from Sheet1. My goal is to make it work automatically, when i paste data from another Workbook, as shown in screenshot example, i polulate range "A10:C27", range width is constant, always 3 column, but rows can change so number is X. Now i need values from "A10:A27" to copy to next empty column from left to right in Sheet"RadniNalog" from cells in 2nd row. Next i also need to copy Value from cell =F$13$ into the first row in sheet "RadniNalog" (on screenshot example its cell "E1" and that value from F13 needs to act like a Header for values belove it. If Value from header is the same as value in cell "F13" i need to continue adding values under existing ones, and if not move to the next available column. In screenshot example, if cell "D1" from sheet "RandiNalog" is same as cell "F13" in Sheet1, then values from range "A10:A27" should be added under last value in ColumnD. I need some VBA code if possible to make it work as wanted. Thanks in advance
Copy this code to Sheet1 module
This code runs the macro copyValuesToWs when you put the code in F13
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F13:G13")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Call copyValuesToWs
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Create a new module and insert this code
Option Explicit
Function FindLastRow(ByVal Col As Byte, ws As Worksheet) As Long
FindLastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function FindLastColumn(ByVal rw As Byte, ws As Worksheet) As Long
FindLastColumn = ws.Cells(rw, Columns.Count).End(xlToLeft).Column
End Function
Sub copyValuesToWs()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Radni nalog")
Dim lCol As Long
Dim lRow As Long
Dim srcRng As Range
Dim dstRng As Range
Dim hdRng As Range
' Next row after ID
Dim idRng As Range: Set idRng = ws1.Range("A10")
' find last row value in column A
lRow = FindLastRow(1, ws1)
' range to be copied
Set srcRng = ws1.Range(ws1.Cells(idRng.Row, 1), ws1.Cells(lRow, 1))
' find last used column in sheet2
lCol = FindLastColumn(1, ws2)
' header range
Set hdRng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lCol))
' check if value exists in header
On Error Resume Next
Dim sValue As Double: sValue = Application.WorksheetFunction.Match(ws1.Range("F13").Value, hdRng, 0)
If Err.Number = 0 Then ' value exists
' find last row
Set dstRng = ws2.Cells(FindLastRow(sValue, ws2) + 1, sValue)
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
Else
' set destination range
Set dstRng = ws2.Cells(2, lCol + 1)
' set header value
ws1.Range("F13:G13").Copy
ws2.Cells(1, lCol + 1).PasteSpecial xlPasteValues
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
Application.CutCopyMode = False
End Sub

Copy Row from every sheet with cell containing word

I am building out a workbook where every sheet is for a different stage of a software installation. I am trying to aggregate the steps that fail by copying my fail rows into a summary sheet. I finally got them to pull, but they are pulling into the new sheet on the same row # as they are located in the original sheet.
Here is what I am using now:
Option Explicit
Sub Test()
Dim Cell As Range
With Sheets(7)
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Fail" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next Cell
End With
End Sub
I need to:
Pull row that has cell containing "Fail"
Copy row into master starting at Row 4 and consecutively down without overwriting
Run across all sheets at once-
*(they are named per step of install - do i need to rename to "sheet1, sheet2, etc"????)
When macro is run clear previous results (to avoid duplicity)
Another user offered me an autofilter macro but it is failing on a 1004 at this line ".AutoFilter 4, "Fail""
Sub Filterfail()
Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Master")
Application.ScreenUpdating = False
'sh.UsedRange.Offset(1).Clear 'If required, this line will clear the Master sheet with each transfer of data.
For Each ws In Worksheets
If ws.Name <> "Master" Then
With ws.[A1].CurrentRegion
.AutoFilter 4, "Fail"
.Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
.AutoFilter
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub
Try this:
The text “Completed” in this xRStr = "Completed" script indicates the specific condition that you want to copy rows based on;
C:C in this Set xRg = xWs.Range("C:C") script indicates the specific column where the condition locates.
Public Sub CopyRows()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "New Sheet"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
If xWs.Name <> xStr Then
Set xRg = xWs.Range("C:C")
Set xRg = Intersect(xRg, xWs.UsedRange)
For Each xRRg In xRg
If xRRg.Value = xRStr Then
xRRg.EntireRow.Copy
xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
xC = xC + 1
End If
Next xRRg
End If
Next xWs
Application.DisplayAlerts = True
End Sub
Here's another way - You'll have to assign your own Sheets - I used 1 & 2 not 2 & 7
Sub Test()
Dim xRow As Range, xCel As Range, dPtr As Long
Dim sSht As Worksheet, dSht As Worksheet
' Assign Source & Destination Sheets - Change to suit yourself
Set sSht = Sheets(2)
Set dSht = Sheets(1)
' Done
dPtr = Sheets(1).Rows.Count
dPtr = Sheets(1).Range("D" & dPtr).End(xlUp).Row
For Each xRow In sSht.UsedRange.Rows
Set xCel = xRow.Cells(1, 1) ' xCel is First Column in Used Range (May not be D)
Set xCel = xCel.Offset(0, 4 - xCel.Column) ' Ensures xCel is in Column D
If xCel.Value = "Fail" Then
dPtr = dPtr + 1
sSht.Rows(xCel.Row).Copy Destination:=dSht.Rows(dPtr)
End If
Next xRow
End Sub
I think one of the problems in your own code relates to this line
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
The section Rows.Count, "A" should be referring to the destination sheet(2) but isn't because of the line
With Sheets(7)
further up

How to reference last used column in a certain row and paste certain value in there

I am working on a macro that loops over a the used range in one sheet (which is the last sheet in the workbook) in a certain column ("H"). The macro should then copy the value, only if it is not 0, and paste it in a sheet called "Overview" in the original row, offset by 3 (e.g. first row becomes 4th row) and in the column behind the last used column in row 5. (I hope that makes sense?). I already worked on some code but I did not manage to reference the last used column correctly and am honestly close to a breakdown.
can someone explain to me what I am doing wrong?
This is what I already have:
Dim Cell As Range, cRange As Range, lrw As Long
Dim wsDestination As Worksheet, wsSource As Worksheet
'set worksheets
With ThisWorkbook
Set wsSource = .Worksheets(Sheets.Count)
Set wsDestination = .Worksheets("Overview")
End With
LastRow1 = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
LastColumn1 = wsDestination.Cells(5, "A").End(xlRight).Column
Set cRange = wsSource.Range(wsSource.Cells(1, 8), wsSource.Cells(LastRow1, 8))
For Each Cell In cRange.Cells
If Cell.Value > 0 Then wsDestination.Cells(Cell.Row, LastColumn1).offset(3, 1) = Cell.Value
Next Cell
End Sub```
The Subtle Differences in Ways of Finding the 'Last Column'
To successfully test the first procedure, in a new worksheet you have to:
write a value in cell A1,
write ="" in cell B1,
write a value in cell C1,
hide column C
and use a fill color in cell D1.
The result of the test will be shown in the Immediate window CTRL+G.
The third procedure is an example of how to use the second procedure, the function for calculating the column of the last non-blank cell in a row using the Find method.
The Code
Option Explicit
Sub LastColumnSuptileDifferences()
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
' Cell Value Comment
' A1: 1 Value
' B1: ="" Formula
' C1 1 Value: Hidden Column
' D1: Fill Color
Debug.Print ws.Rows(1).Find("*", , xlFormulas, , , xlPrevious).Column ' 3
Debug.Print ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' 2
Debug.Print ws.Rows(1).Find("*", , xlValues, , , xlPrevious).Column ' 1
Debug.Print ws.Rows(1).CurrentRegion.Columns.Count ' 3
Debug.Print ws.Rows(1).SpecialCells(xlCellTypeLastCell).Column ' 4
Debug.Print ws.UsedRange.Rows(1).Columns.Count ' 4
End Sub
' This will find the last column even if columns are hidden
' unless you set 'excludeEmpties' to 'True'.
' If you set 'excludeEmpties' to 'True', the right-most cells in the row,
' possibly containing a formula that evaluates to "", will be skipped.
' Additionally only the visible cells will be included, i.e. hidden
' right-most columns, possibly containing data in cells of the row,
' will not be considered (mimicking 'End(xlToLeft)' or CRTL+Left).
Function getLastColumnInRow(RowNumber As Variant, _
Optional Sheet As Worksheet = Nothing, _
Optional excludeEmpties As Boolean = False)
If Sheet Is Nothing Then
Set Sheet = ActiveSheet
End If
Dim FormVal As XlFindLookIn
If excludeEmpties Then
FormVal = xlValues
Else
FormVal = xlFormulas
End If
Dim rng As Range
Set rng = Sheet.Rows(RowNumber).Find(What:="*", _
LookIn:=FormVal, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
getLastColumnInRow = rng.Column
Else
getLastColumnInRow = 0
End If
End Function
Sub testgetLastColumnInRow()
'...
LastColumn1 = getLastColumnInRow(5, wsDestination)
If LastColumn1 = 0 Then
MsgBox "No Data.", vbExclamation, "Empty Row"
Exit Sub ' or whatever
End If
' Continue with code.
Debug.Print LastColumn1
'...
End Sub
So you didn't quite get the last column right. Here's it back.
Dim Cell As Range, cRange As Range, lrw As Long
Dim wsDestination As Worksheet, wsSource As Worksheet
'set worksheets
With ThisWorkbook
Set wsSource = .Worksheets(Sheets.Count)
Set wsDestination = .Worksheets("Overview")
End With
LastRow1 = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
LastColumn1 = wsDestination.Cells(5, columns.count).End(xltoleft).Column
Set cRange = wsSource.Range(wsSource.Cells(1, 8), wsSource.Cells(LastRow1, 8))
For Each Cell In cRange.Cells
If Cell.Value > 0 Then wsDestination.Cells(Cell.Row, LastColumn1).offset(3, 1) = Cell.Value
Next Cell
End Sub```

Add Error Message If Criteria Doesn't Match

Look for (HERE) in below code for line I'm talking about.
Is it possible to setup an error message if it doesn't find any criteria "Active" in Column D?
I tried inputting an on error goto but it gave the msgbox when there were no "Active" projects in column D. But as soon as there was an "Active" Cell it would error out and not finish the code.
I did use a Exit Sub and Resume but still didn't work.
Const cCrit As Variant = "D" ' Criteria Column Letter/Number
Const cCols As String = "C:J" ' Source/Target Data Columns
Const cFRsrc As Long = 15 ' Source First Row
Dim ws1 As Worksheet ' Source Workbook
Dim ws2 As Worksheet ' Target Workbook
Dim rng As Range ' Filter Range, Copy Range
Dim lRow As Long ' Last Row Number
Dim FRtgt As Long ' Target First Row
Dim Answer As VbMsgBoxResult ' Message Box
Dim Error1 As VbMsgBoxResult ' Message Box for Errors
' Create references to worksheets.
With ThisWorkbook
Set ws1 = .Worksheets("Future Project Hopper")
Set ws2 = .Worksheets("CPD-Carryover,Complete&Active")
End With
Answer = MsgBox("Do you want to run the Macro?", vbYesNo, "Run Macro")
If Answer <> vbYes Then Exit Sub
' In Source Worksheet
With ws1
' Clear any filters.
.AutoFilterMode = False
' Calculate Last Row.
lRow = .Cells(.Rows.Count, cCrit).End(xlUp).row
' Calculate Filter Column Range.
Set rng = .Cells(cFRsrc, cCrit).Resize(lRow - cFRsrc + 1)
' Make an offset for the filter to start a row before (above) and
' end a row after (below).
With rng.Offset(-1).Resize(lRow - cFRsrc + 3)
' Filter data in Criteria Column.
.AutoFilter Field:=1, Criteria1:="Active"
End With
' Create a reference to the Copy Range.
**(HERE)** Set rng = .Columns(cCols).Resize(rng.Rows.Count).Offset(cFRsrc - 1) _
.SpecialCells(xlCellTypeVisible)
' Clear remaining filters.
.AutoFilterMode = False
End With
' Calculate Target First Row.
FRtgt = ws2.Cells(ws2.Rows.Count, cCrit).End(xlUp).row + 1
' Copy Range and paste to Target Worksheet and clear contents of future project hopper
rng.Copy
ws2.Columns(cCols).Resize(1).Offset(FRtgt - 1).PasteSpecial xlPasteValues
rng.Rows.ClearContents
Application.CutCopyMode = False
Give this a shot:
On Error Resume Next
Set Rng = .Columns(cCols).Resize(Rng.Rows.Count).Offset(cFRsrc - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Rng Is Nothing Then
MsgBox "No criteria found! Exiting sub"
Exit Sub
End If

hiding blank columns on multiple sheets

I want to hide the blank columns on multiple sheets. I can do it on just the active sheet but when I try to make it so it applies to all sheets with a month in the name it doesn't work. This is what I have so far:
Sub CommandButton1_Click()
Dim col As Range
Dim sheetsArray As Sheets
Set sheetsArray = ActiveWorkbook.Sheets(Array("*Jan*", "*Feb*", "*Mar*", "*Apr*", "*May*", "*Jun*", "*Jul*", "*Aug*", "*Sep*", "*Oct*", "*Nov*", "*Dec*"))
Dim sheet As Worksheet
Application.ScreenUpdating = False
For Each sheet In sheetsArray
sheet.Columns.Hidden = False
For Each col In sheet.UsedRange.Columns
col.Hidden = sheet.col.Cells(Rows.Count, 1).End(xlUp).Row = 1
Next col
Next sheet
Application.ScreenUpdating = True
End Sub
It's also now giving me a "Method or Data member not found error"
The Worksheet class does not have a method or data member named col. You can remove sheet. in front of col. Also, at the top of your module, add Option Explicit; then, before running your code, click the Debug menu and then Compile in order to catch such issues early on.
Other than that, you will have to check each sheet name against your name filters; the ActiveWorkbook.Sheets collection unfortunately won't magically interpret the filters in your array. In the end, you can go along those lines:
Option Explicit
Sub CommandButton1_Click()
Dim sheet As Worksheet
Dim col As Range
Dim sheetNameFilters As Variant
Dim filter As Variant
sheetNameFilters = Array("*Jan*", "*Feb*", "*Mar*", "*Apr*", "*May*", "*Jun*", "*Jul*", "*Aug*", "*Sep*", "*Oct*", "*Nov*", "*Dec*")
Application.ScreenUpdating = False
For Each sheet In ThisWorkbook.Worksheets
For Each filter In sheetNameFilters
If sheet.Name Like filter Then
sheet.Columns.Hidden = False
For Each col In sheet.UsedRange.Columns
col.Hidden = (col.Cells(Rows.Count, 1).End(xlUp).Row = 1)
Next
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub
I'm not sure if Array can perform the wild card search as you intended to. Like is a function that can be used as shown in the code below. Hope it meets your needs
Sub HideColumns()
Dim col As Range
Dim sheet As Worksheet
Application.ScreenUpdating = False
For Each sheet In ThisWorkbook.Worksheets
'check if worksheet name as month in it
If sheet.Name Like "*Jan*" Or sheet.Name Like "*Feb*" Or sheet.Name Like "*Mar*" Then 'add for rest of the months
sheet.Columns.Hidden = False 'make all columns visible
DoEvents
'reset the user range
sheet.UsedRange.Calculate 'if you are using usedrange recommend using this as sometimes usedrange behaves erratically
For Each col In sheet.UsedRange.Columns
'check if there are no entries and first row is also blank - make blank if both conditions are met
col.Hidden = IIf(col.Cells(1048576, 1).End(xlUp).Row = 1 And col.Cells(1, 1).Value = "", True, False)
DoEvents
Next col
End If
Next sheet
Application.ScreenUpdating = True
End Sub
Hide or Delete Blank Columns in Real Used Range
(Usually) Standard Module (Often 'Module1')
Option Explicit
'*******************************************************************************
' Purpose: Hides or deletes all blank columns in the Real Used Range
' of worksheets specified by a name pattern list.
' Remarks: The Real Used Range is calculated by using the Find method which
' avoids any possible 'errors' occuring when using the UsedRange
' property.
'*******************************************************************************
Sub HideDeleteColumnsOfRUR(Optional HideFalse_DeleteTrue As Boolean = False)
' Worksheet Name Pattern List
Const cSheets As String = "*Jan*,*Feb*,*Mar*,*Apr*,*May*,*Jun*,*Jul*," _
& "*Aug*,*Sep*,*Oct*,*Nov*,*Dec*"
' If a cell contains a formula that evaluates to "" and if cLookIn is
' equal to xlValues (-4163), it will not be found (Not blank).
Const cLookIn As Variant = -4123 ' -4163 Value, -4123 Formula, -4144 Comment
Dim ws As Worksheet ' (Current) Worksheet
Dim RUR As Range ' (Current) Real Used Range
Dim rngU As Range ' (Current) Union Range
Dim vntSheets As Variant ' Sheet Array
Dim i As Long ' Sheet Array Row Counter
Dim j As Long ' Used Range Column Counter
Application.ScreenUpdating = False
On Error GoTo ProcedureExit ' Enable ScreenUpdating if error occurs.
' Write Worksheet Name Pattern List to Sheet Array.
vntSheets = Split(cSheets, ",")
' Remove possible occurrences of leading and trailing spaces in
' Sheet Array.
'For i = 1 To UBound(vntSheets): vntSheets(i) = Trim(vntSheets(i)): Next
For Each ws In ThisWorkbook.Worksheets ' Loop through worksheets.
For i = 0 To UBound(vntSheets) ' Loop through Worksheet Name Patterns.
If ws.Name Like vntSheets(i) Then ' Worksheet Name Pattern found.
' Unhide all columns, calculate Real Used Range and Union Range.
GoSub RangeAccumulator
Exit For ' Stop checking for (Current) Worksheet Name Patterns.
End If
Next
Next
ProcedureExit:
Application.ScreenUpdating = True
Exit Sub
RangeAccumulator:
With ws
' Unhide all columns in (Current) Worksheet.
.Columns.Hidden = False
' Calculate Real Used Range.
If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns _
.Count), -4123, , 1) Is Nothing Then ' Is not empty sheet.
Set RUR = .Range(.Cells(.Cells.Find("*", .Cells(.Rows.Count, _
.Columns.Count)).Row, .Cells.Find("*", .Cells(.Rows.Count, _
.Columns.Count), , , 2).Column), .Cells(.Cells _
.Find("*", , , , 1, 2).Row, .Cells.Find("*", , , , 2, 2) _
.Column))
Else ' Is empty sheet.
'MsgBox "Worksheet '" & ws.Name & "' is an empty sheet."
Return
End If
End With
' Accumulate Union Range using only Real Used Range's first-row cells (1).
With RUR
For j = 1 To .Columns.Count
If .Columns(j).Find("*", , cLookIn, , 2, 2) Is Nothing Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(1, j))
Else
Set rngU = .Cells(1, j)
End If
End If
Next
End With
' Hide or Delete Union Range's columns.
If Not rngU Is Nothing Then
With rngU.EntireColumn
If Not HideFalse_DeleteTrue Then
.Hidden = True
Else
.Delete
End If
End With
Set rngU = Nothing
End If
Return
End Sub
'*******************************************************************************
'*******************************************************************************
' Purpose: Shows (unhides) all blank columns in worksheets specified by
' a name pattern list.
'*******************************************************************************
Sub ShowAllColumns()
' Worksheet Name Pattern List
Const cSheets As String = "*Jan*,*Feb*,*Mar*,*Apr*,*May*,*Jun*,*Jul*," _
& "*Aug*,*Sep*,*Oct*,*Nov*,*Dec*"
Dim ws As Worksheet ' (Current) Worksheet
Dim vntSheets As Variant ' Sheet Array
Dim i As Long ' Sheet Array Row Counter
Application.ScreenUpdating = False
On Error GoTo ProcedureExit ' Enable ScreenUpdating if error occurs.
' Write Worksheet Name Pattern List to Sheet Array.
vntSheets = Split(cSheets, ",")
' Remove possible occurrences of leading and trailing spaces in
' Sheet Array.
'For i = 1 To UBound(vntSheets): vntSheets(i) = Trim(vntSheets(i)): Next
For Each ws In ThisWorkbook.Worksheets ' Loop through worksheets.
For i = 0 To UBound(vntSheets) ' Loop through Worksheet Name Patterns.
If ws.Name Like vntSheets(i) Then ' Worksheet Name Pattern found.
' Unhide all columns in (Current) Worksheet.
ws.Columns.Hidden = False
Exit For ' Stop checking for (Current) Worksheet Name Patterns.
End If
Next
Next
ProcedureExit:
Application.ScreenUpdating = True
End Sub
'*******************************************************************************
(Usually) Sheet Module (Often 'Sheet1', 'Sheet2' or...)
Option Explicit
'*******************************************************************************
Sub CommandButton1_Click()
' HIDES columns in Real Used Range.
HideDeleteColumnsOfRUR
End Sub
'*******************************************************************************
Sub CommandButton2_Click()
' Shows (unhides) columns.
ShowAllColumns
End Sub
'*******************************************************************************
'Sub CommandButton3_Click()
' ' DELETES columns in Real Used Range.
' HideDeleteColumnsOfRUR True ' (or probably any number different than 0.)
'End Sub
'*******************************************************************************

Resources