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
Related
The code works when the criteria exists. I get an error when the criteria doesn't exist.
' Define constants.
Const srcName As String = "wfm_rawdata"
Const srcFirst As String = "D2" ' Location for Group
Const dstName As String = "bond_insurance"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
'This function will transfer rows from one worksheet to another worksheet
' if the value = specified critiera
' Define workbook.
Dim wb As Workbook: Set wb = ActiveWorkbook ' Workbook containing this code.
' Define Source Range
Dim LastRow As Long
Dim srg As Range
' Define worksheet and column am working on and
' getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Combine' critical cells into a range.
Dim brg As Range ' Built Range --> Range in the new sheet
Dim cel As Range ' Current Cell Range --> Range in the current sheet(rawdata)
'for every cell in group within wfm_rawdata sheet if the value = GO
For Each cel In srg.Cells
If cel.Value = "BOND INSURANCE" Then
' If the range in the new sheet have nothing then
' add specific criteria from the group in wfm_rawdata
If brg Is Nothing Then
Set brg = cel
' if there is range in there combine the new and
' old range together using -> Union function
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
How can I use a Boolean or other function to bypass the above code if the criteria doesn't exist?
For example if criteria "dog" exists then run the code and if it doesn't exist bypass the code.
I use this code to run three modules with code similar to the top code.
Sub master()
Call report1
Call report2
Call report3
End Sub
One you've assigned srg you can use Match() to check whether it contains any instances of the term you're interested in:
'...
'...
' Define worksheet and column am working on and getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Exit if "BOND INSURANCE" is not found in `srg`
If IsError(Application.Match("BOND INSURANCE", srg, 0)) Then Exit Sub
'...
'...
In the picture below, I'm trying to hide the rows that are empty in a certain cells (e.g. Row 39 to Row 48). Is is possible to do it in one click? I'm planning of doing it with VBA.
This is the formula that I'm currently using but the thing is the cells that I want to hide may not start at row 39 or ends at row 48, it depends on the data.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
'ws.Rows("39:48").Hidden = True
Next
End Sub
Hide 'Empty' Rows
This is a slightly different approach:
uses Option Explicit
uses constants and variables
uses For Each...Next loops for both, worksheets and cells
qualifies all objects (e.g. ws.Cells or rg.Cells, not just Cells)
combines empty cells into a range
unhides all rows in one go, then hides the 'empty' rows in another (go)
Option Explicit
Sub HideRows()
Const StartRow As Long = 9
Const EndRow As Long = 89
Const ColNum As Long = 3
Dim WorksheetNames As Variant
WorksheetNames = Array("NAMES", "AUGUST") ' add more
Dim ws As Worksheet ' Current Worksheet
Dim rg As Range ' Current Range
Dim hrg As Range ' Current Hide Range
Dim cCell As Range ' Current Cell in Range
' Loop through the worksheets in the workbook containing this code.
For Each ws In ThisWorkbook.Worksheets(WorksheetNames)
' Create a reference to the range of the current worksheet.
Set rg = ws.Range(ws.Cells(StartRow, ColNum), ws.Cells(EndRow, ColNum))
' or using resize:
'Set rg = ws.Cells(StartRow, ColNum).Resize(EndRow - StartRow + 1)
' Loop through the cells of the current range.
For Each cCell In rg.Cells
If IsEmpty(cCell) Then ' cell is empty
' Combine ('add') the current cell into the hide range.
If Not hrg Is Nothing Then ' for all except the first
Set hrg = Union(hrg, cCell)
Else ' for the first
Set hrg = cCell
End If
'Else ' cell is not empty - do nothing
End If
Next cCell
' Unhide all rows of the current range of the current worksheet.
rg.EntireRow.Hidden = False
If Not hrg Is Nothing Then ' there are combined cells
' Hide the rows of the hide range.
hrg.EntireRow.Hidden = True
' Reset the hide range variable for the next worksheet.
' Also, note that 'Union' works only with ranges from one worksheet.
Set hrg = Nothing
'Else ' there are no combined cells - do nothing
End If
Next ws
End Sub
I already made it. Below is the script that I used.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
StartRow = 9
EndRow = 89
ColNum = 3
For i = StartRow To EndRow
If Not IsEmpty(Cells(i, ColNum).Value) Then
ws.Cells(i, ColNum).EntireRow.Hidden = False
Else
ws.Cells(i, ColNum).EntireRow.Hidden = True
End If
Next i
Next
End Sub
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
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
'*******************************************************************************
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