I have a macro that hides rows based on cell values. I am attempting to use this across multiple sheets in the workbook, but not all of them. My code below seems to run the macro multiple times in the same sheet.
Sub HideRowsWbk()
Dim LastRow As Long
Dim Rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
With ThisWorkbook
For Each ws In .Worksheets
Select Case ws.Name
Case "0000_Index", "000_BidItems", "000_EntrySheet", "000_PayReqs"
'do nothing - exclude these sheets
Case Else
With ws
LastRow = Range("A65536").End(xlUp).Row '
Set Rng = Range("M15:M" & LastRow) 'choose column where value exists
For Each cell In Rng
If cell.Value = "0" Or cell.Value = "-" Then 'checks if cell value is 0 or -
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Select
Next ws
End With
Application.ScreenUpdating = True
End Sub
Please tell me what I have done wrong and how I can fix this. Also please show me how I can improve my minimal coding skills. I am using Excel 2007.
Thank you.
use:
LastRow = .Range("A65536").End(xlUp).Row '
Set Rng = .Range("M15:M" & LastRow) 'choose column where value exists
the "." makes it work with ws
Related
Is there a way to identify if a worksheet has a highlighted cell at a worksheet level, without checking all the cells?
Further context:
I have a WorkBook with a number of Worksheets(ws).
some of the worksheets have cells that are highlighted.
I want to be able to take out the worksheets that have a cell highlighted and put them in another workbook.
But the way I do it is, I go through each cell in each worksheet to find a highlighted cell, and when I find one, I copy this worksheet to another workbook and move on to the next work sheet.
But the more ws there are the longer this takes and because I have to go through individual cells.
So my questions is, Is there a way to identify if a worksheet has a highlighted cell at a worksheet level? Or do I have to go through each cell range in each worksheet?
Code
' copy the path from cell a1 to the master in a1, a2, a3.....
' want to add to copy the WS if it has a highlighted area
' added copy ws with highlight to new WB and exit for loop for checking more highlighted areas
' this works C:\Samsung\Macros\test_macro_test3.xlsm, see cloumn A in master sheet and have Summary.xlsm WB open
Sub test3()
Dim startTime, endTime As Date
startTime = Now
Dim ws As Worksheet, MainWs As Worksheet, cell As Range
Set MainWs = Sheets("master") '<-- change name as needed
Dim i As Integer
i = 1
For Each ws In Sheets
If ws.Name <> MainWs.Name Then
For Each cell In ws.UsedRange
Debug.Print "ws.Name:" & ws.Name
Debug.Print "cell.Address:" & cell.Address
Debug.Print "cell.Value:" & cell.Value
Debug.Print "i:" & i
'if your cells are colored through conditional formatting, delete/comment below line & uncomment the line after
If cell.Interior.Color = vbYellow Then
MainWs.Range("A" & i) = ws.Range("A1").Value
MainWs.Range("B" & i) = ws.Name
ws.Copy After:=Workbooks("Summary.xlsm").Sheets(Workbooks("Summary.xlsm").Sheets.Count)
Exit For
'If cell.DisplayFormat.Interior.Color = vbYellow Then MainWs.Range(cell.Address) = cell.Value
Debug.Print "cell.Address:" & cell.Address
Debug.Print "cell.Value:" & cell.Value
Debug.Print "i:" & i
Exit For
End If
Next
End If
i = i + 1
Next 'next worksheet
endTime = Now
Debug.Print "startTime:" & startTime
Debug.Print "endTime: " & endTime
Debug.Print "Total(hh:mm:ss)" & Format((DateDiff("s", startTime, endTime)) / 86400, "hh:mm:ss")
End Sub
WB examples
https://www.dropbox.com/scl/fi/7x91vwbvv62nn15loczpy/test_macro_test3.xlsm?dl=0&rlkey=k8b53wizejaf4jqwjzilthvg2
https://www.dropbox.com/scl/fi/8c5uatqyhlwlv5pzcude7/Summary.xlsm?dl=0&rlkey=fodf1j7ic7ac5pl9coehnlhab
You can use the following function to check if a worksheet has cells with a certain background color:
Public Function hasSheetHighlightedCells(ws As Worksheet, _
Optional lngColor As Long = vbYellow) As Boolean
Application.FindFormat.Clear
Application.FindFormat.Interior.color = lngColor
Dim rgFound As Range
On Error Resume Next 'in case nothing can be found
Set rgFound = ws.UsedRange.Find("*", searchFormat:=True)
On Error GoTo 0
If Not rgFound Is Nothing Then
hasSheetHighlightedCells = True
End If
Application.FindFormat.Clear
End Function
You will call that function within your For each ws in Sheets loop:
If hasSheetHighlightedCells(ws) = true then
This will check for the default color vbYellow.
If you want to check for a different color you can use e.g.
If hasSheetHighlightedCells(ws, vbRed) = true then
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
I am trying to select rows in a table based on the word "Yes" being present in column J.
I have a table going from column A to J, and I want to select the rows where there is a "Yes" in column J and paste only those rows into a new sheet.
Once selected, I need to copy these rows to a new sheet or word document.
I have tried a range of forumulas, this is for Windows MS Excel software, using a VBA Macro.
I am using the following VBA, but having issues:
Sub Macro1()
Dim rngJ As Range
Dim cell As Range
Set rngJ = Range("J1", Range("J65536").End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
cell.EntireRow.Copy
wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next cell
End Sub
Any help would be very much appreciated!
Rather than finding, copying and pasting for each cell, why not find all, then copy and paste once like this:
Sub Macro1()
Dim rngJ As Range
Dim MySel As Range
Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
If MySel Is Nothing Then
Set MySel = cell.EntireRow
Else
Set MySel = Union(MySel, cell.EntireRow)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub
It's better to avoid using Select as much as possible; see this link.
Use something like this
Option Explicit
Public Sub CopyYesRowsToNewWorksheet()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")
Dim DataRangeJ As Variant 'read "yes" data into array for faster access
DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Worksheets.Add
Dim NextFreeRow As Long
NextFreeRow = 1 'start pasting in this row in the new sheet
If IsArray(DataRangeJ) Then
Dim iRow As Long
For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
If DataRangeJ(iRow, 1) = "yes" Then
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
NextFreeRow = NextFreeRow + 1
End If
Next iRow
ElseIf DataRangeJ = "yes" Then 'if only the first row has data
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
End If
End Sub
The line
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value
only copys the value without formatting. If you also want to copy the formatting replace it with
wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)
I have an excel workbook, in worksheet1 in Column A, IF the value of that column = ERR I want it to be deleted (the entire row), how is that possible?
PS: keep in mind that I have never used VBA or Macros before, so detailed description is much appreciated.
Using an autofilter either manually or with VBA (as below) is a very efficient way to remove rows
The code below
Works on the entire usedrange, ie will handle blanks
Can be readily adpated to other sheets by changing strSheets = Array(1, 4). ie this code currently runs on the first and fourth sheets
Option Explicit
Sub KillErr()
Dim ws As Worksheet
Dim lRow As Long
Dim lngCol As Long
Dim rng1 As Range
Dim strSheets()
Dim strws As Variant
strSheets = Array(1, 4)
For Each strws In strSheets
Set ws = Sheets(strws)
lRow = ws.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
lngCol = ws.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
Application.ScreenUpdating = False
ws.Rows(1).Insert
Set rng1 = ws.Range(ws.Cells(1, lngCol), ws.Cells(lRow + 1, lngCol))
With rng1.Offset(0, 1)
.FormulaR1C1 = "=RC1=""ERR"""
.AutoFilter Field:=1, Criteria1:="TRUE"
.EntireRow.Delete
On Error Resume Next
.EntireColumn.Delete
On Error GoTo 0
End With
Next
Application.ScreenUpdating = True
End Sub
sub delete_err_rows()
Dim Wbk as Excel.workbook 'create excel workbook object
Dim Wsh as worksheet ' create excel worksheet object
Dim Last_row as long
Dim i as long
Set Wbk = Thisworkbook ' im using thisworkbook, assuming current workbook
' if you want any other workbook just give the name
' in invited comma as "workbook_name"
Set Wsh ="sheetname" ' give the sheet name here
Wbk.Wsh.activate
' it means Thisworkbook.sheets("sheetname").activate
' here the sheetname of thisworkbook is activated
' or if you want looping between sheets use thisworkbook.sheets(i).activate
' put it in loop , to loop through the worksheets
' use thisworkbook.worksheets.count to find number of sheets in workbook
Last_row = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row 'to find the lastrow of the activated sheet
For i = lastrow To 1 step -1
if activesheet.cells(i,"A").value = "yourDesiredvalue"
activesheet.cells(i,"A").select ' select the row
selection.entirerow.delete ' now delete the entire row
end if
Next i
end sub
Note any operations that you do using activesheet , will be affected on the currently activated sheet
As your saying your a begginner, why dont you record a macro and check out, Thats the greatest way to automate your process by seeing the background code
Just find the macros tab on the sheet and click record new macro , then select any one of the row and do what you wanted to do , say deleting the entire row, just delete the entire row and now go back to macros tab and click stop recording .
Now click alt+F11 , this would take you to the VBA editor there you find some worksheets and modules in the vba project explorer field , if you dont find it search it using the view tab of the VBA editor, Now click on module1 and see the recorded macro , you will find something like these
selection.entirerow.delete
I hope i helped you a bit , and if you need any more help please let me know, Thanks
Fastest method:
Sub DeleteUsingAutoFilter()
Application.ScreenUpdating = False
With ActiveSheet
.AutoFilterMode = False
.Columns("A").AutoFilter Field:=1, Criteria1:="ERR"
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Second fastest method (lots of variations to this one too):
Sub DeleteWithFind()
Dim rFound As Range, rDelete As Range
Dim sAddress As String
Application.ScreenUpdating = False
With Columns("A")
Set rFound = .Find(What:="ERR", After:=.Resize(1, 1), SearchOrder:=xlByRows)
If Not rFound Is Nothing Then
Set rDelete = rFound
Do
Set rDelete = Union(rDelete, rFound)
Set rFound = .FindNext(rFound)
Loop While rFound.Row > rDelete.Row
End If
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub
Autofilter method for multiple sheets:
Sub DeleteUsingAutoFilter()
Dim vSheets As Variant
Dim wsLoop As Worksheet
Application.ScreenUpdating = False
'// Define worksheet names here
vSheets = Array("Sheet1", "Sheet2")
For Each wsLoop In Sheets(vSheets)
With wsLoop
.AutoFilterMode = False
.Columns("A").AutoFilter Field:=1, Criteria1:="ERR"
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Next wsLoop
Application.ScreenUpdating = True
End Sub
Assuming there are always values in the cells in column A and that the data is in the first sheet, then something like this should do what you want:
Sub deleteErrRows()
Dim rowIdx As Integer
rowIdx = 1
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
While ws.Cells(rowIdx, 1).Value <> ""
If ws.Cells(rowIdx, 1).Value = "ERR" Then
ws.Cells(rowIdx, 1).EntireRow.Delete
Else
rowIdx = rowIdx + 1
End If
Wend
End Sub
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps