I'm trying to delete all cells with strikethrough from a Workbook and iterate on all sheets at the same time.
I have followed this, this and this and come up with two macros, but they are not working. This is the first time that I use VBA so I'm not sure of how to fix these problems.
Sub DeleteCells()
Dim Cell As Range, iCh As Integer, NewText As String
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
With Sheets(I) ' <~~ avoid select as much as possible, work directly with the objects
Lrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each Cell In .Range("C1:M" & Lrow)
For iCh = 1 To Len(Cell)
With Cell.Characters(iCh, 1)
If .Font.Strikethrough = False Then NewText = NewText & .Text
End With
Next iCh
Cell.Value = NewText ' <~~ You were doing it the other way around
NewText = "" ' <~~ reset it for the next iteration
Cell.Characters.Font.Strikethrough = False
Next Cell
End With
Next I
End Sub
In this case I get "Unable to get the Text property of the Character class"
Sub LoopThroughAllTablesinWorkbook()
Dim tbl As ListObject
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
With Sheets("sht")
Lrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each Cell In .Range("C1:M" & Lrow)
For iCh = 1 To Len(Cell)
With Cell.Characters(iCh, 1)
If .Font.Strikethrough = False Then NewText = NewText & .Text
End With
Next iCh
Cell.Value = NewText ' <~~ You were doing it the other way around
NewText = "" ' <~~ reset it for the next iteration
Cell.Characters.Font.Strikethrough = False
Next Cell
End With
Next sht
End Sub
In this case I get as an error: Subscript out of range, which refers to the With Sheets part.
Try this
Sub DeleteCells()
Dim cel As Range
Dim ws As Worksheet
Dim lastRow As Long
For Each ws In ActiveWorkbook.Worksheets 'loop through all sheets
With ws
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 'get last row with data using Column C
For Each cel In .Range("C1:M" & lastRow) 'loop through all cells in range
If cel.Font.Strikethrough Then 'check if cell has strikethrough property
cel.Clear 'make cell blank and remove strikethrough property
End If
Next cel
End With
Next ws
End Sub
Related
Instead of hard coding the value to be looked up ("1234"), I would like to use a range of values, on a separate worksheet("Items") to use as the search criteria.
I would also like to substitute that same value for the destination sheet.
For example, the first value in the range could be "8754", I would like the code to look for this value then paste the columns, A,B,C,F and the cell containing the value onto the worksheet "8754". (I have all of the worksheets created already)
TIA
Sub Test()
Dim Cell As Range
With Sheets("Sheet1") 'Sheet with data to check for value
For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
pos = InStr(Cell.Value, "1234")
If pos > 0 Then
NextFreeRow = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count,
"A").End(xlUp).Row + 1
'get the next empty row to paste data to
.Range("A" & Cell.Row & ",B" & Cell.Row & ",C" & Cell.Row & ",F" &
Cell.Row & "," & Cell.Address).Copy Destination:=Sheets("Sheet2").Range("A" & NextFreeRow)
End If
Next Cell
End With
End Sub
This uses FIND rather than FILTER to copy the correct rows.
The Main procedure defines the range you're searching and which values will be searched for. The FindValues procedure finds the value and copies it to the correct sheet.
This assumes that Sheet3!A1:A3 contains a unique list of values to be searched for and the these values can be found in Sheet1!H:H.
It also assumes that all sheets already exist.
Public Sub Main()
Dim rToFind As Range
Dim rValue As Range
Dim rSearchRange As Range
With ThisWorkbook
'Update to the range being searched.
With .Worksheets("Sheet1")
Set rSearchRange = .Range("H1", .Cells(.Rows.Count, 8).End(xlUp))
End With
'Update to the range containing the values to be searched for.
Set rToFind = .Worksheets("Sheet3").Range("A1:A3")
End With
'Passe each of the values to be searched to the FindValues procedure.
For Each rValue In rToFind
FindValues rValue, rSearchRange
Next rValue
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Alternative method to look for hard-coded values.
' `ValuesToFind` in FindValues procedure will needed changing to a Variant.
'
' Dim vAlternativeSearch As Variant
' Dim vAlternativeValue As Variant
' vAlternativeSearch = Array(1475, 1683, 219)
'
' For Each vAlternativeValue In vAlternativeSearch
' FindValues vAlternativeValue, rSearchRange
' Next vAlternativeValue
End Sub
Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)
Dim rFound As Range
Dim sFirstAddress
Dim rLastUsedCell As Range
'Find the next available row on the referenced sheet.
With ThisWorkbook.Worksheets(CStr(ValueToFind))
Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
End With
With RangeToSearch
'Find the first value.
Set rFound = .Find(What:=ValueToFind, _
After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
LookAt:=xlPart, _
SearchDirection:=xlNext)
'If the first value exists then remember the address, copy the cells to the
'correct sheet and look for the next row with the same value. Stop when
'it reaches the first address again.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
'You may have to muck around with this to get the correct range to copy.
'If rFound is in column H this will copy columns B:D and F.
Union(rFound.Offset(, -6).Resize(, 3), rFound.Offset(, -2)).Copy Destination:=rLastUsedCell
Set rLastUsedCell = rLastUsedCell.Offset(1)
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Edit 1:
You say the worksheets already exists, but in your comment you say put it in a brand new sheet.
To add a new sheet add this function:
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
and then add this code directly after the variable declaration in the FindValues procedure:
Dim wrkSht As Worksheet
If Not WorkSheetExists(CStr(ValueToFind)) Then
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = CStr(ValueToFind)
End If
Edit 2:
This updated code searches columns Q:Z, returns the values from A:L as well as the found cell.
To update from the original code I had to change rSearchRange to look from Q1 to column 26, and update the Copy/Paste line to return the correct range.
Public Sub Main()
Dim rToFind As Range
Dim rValue As Range
Dim rSearchRange As Range
With ThisWorkbook
'Update to the range being searched.
With .Worksheets("Data")
Set rSearchRange = .Range("Q1", .Cells(.Rows.Count, 26).End(xlUp))
End With
'Update to the range containing the values to be searched for.
Set rToFind = .Worksheets("Items").Range("A1:A2")
End With
'Passe each of the values to be searched to the FindValues procedure.
For Each rValue In rToFind
FindValues rValue, rSearchRange
Next rValue
End Sub
Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)
Dim rFound As Range
Dim sFirstAddress
Dim rLastUsedCell As Range
'Find the next available row on the referenced sheet.
With ThisWorkbook.Worksheets(CStr(ValueToFind))
Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
End With
With RangeToSearch
'Find the first value.
Set rFound = .Find(What:=ValueToFind, _
After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
LookAt:=xlPart, _
SearchDirection:=xlNext)
'If the first value exists then remember the address, copy the cells to the
'correct sheet and look for the next row with the same value. Stop when
'it reaches the first address again.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
'Parent of RangeToSeach range which will be the Data worksheet.
With .Parent
'Copy columns A:L (columns 1 to 12) and the found cell.
Union(.Range(.Cells(rFound.Row, 1), .Cells(rFound.Row, 12)), rFound).Copy Destination:=rLastUsedCell
End With
Set rLastUsedCell = rLastUsedCell.Offset(1)
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Option Explicit
Public Sub Test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, lr1 As Long, lr2 As Long
Dim luArr As Variant, luVal As Variant, r As String, itm As Variant, itmRow As Long
Set ws1 = ThisWorkbook.Worksheets("Data") 'Sheet with data to check for value
Set ws3 = ThisWorkbook.Worksheets("Items") 'LookUp values
luArr = ws3.UsedRange.Columns("A") 'LookUp column
lr1 = ws1.Cells(ws1.Rows.Count, "H").End(xlUp).Row
Dim findRng As Range, copyRng As Range, toRng As Range, fr As Long
Set findRng = ws1.Range("H1:H" & lr1)
On Error Resume Next 'Expected error: sheet not found
Application.ScreenUpdating = False
For Each luVal In luArr
Set ws2 = Nothing
Set ws2 = ThisWorkbook.Worksheets(luVal) 'Copy to
If ws2 Is Nothing Then
Err.Clear
Else
itm = Application.Match(luVal, findRng, 0)
If Not IsError(itm) Then
findRng.AutoFilter Field:=1, Criteria1:="*" & luVal & "*"
fr = IIf(findRng.SpecialCells(xlCellTypeVisible).Cells.Count = 1, 1, 2)
With ws1.UsedRange
Set copyRng = .Range("A" & fr & ":C" & lr1)
Set copyRng = Union(copyRng, .Range("F" & fr & ":F" & lr1))
Set copyRng = Union(copyRng, .Range("H" & fr & ":H" & lr1))
End With
lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
copyRng.Copy
ws2.Cells(lr2, 1).PasteSpecial
findRng.AutoFilter
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet1
Items
Before (Sheet A1, A2, and A3)
After
I have this code that loops all the sheets in my workbook and need to skip some of the sheets that will be hidden in my workbook by their codename
This is the code im using.
Dim WS As Worksheet
For Each WS In Worksheets
'Skips sheets below
example Skip .sheetscodename, .sheetscodename2, and so on
'Insert code to be looped here
Set Rng = WS.Range("C7", WS.Range("C1048576").End(xlUp))
For Each cel In Rng
If cel.Value = "0" Then
cel.EntireRow.Hidden = True
End If
Next cel
'Next sheet
Next WS
One method is to create a string of all the names to be skipped, then use InStr():
Dim WS As Worksheet
Dim cel As Range, Rng As Range
Dim shts As String
shts = ("sheetscodename,sheetscodename2,...")
For Each WS In Worksheets
If InStr(1, shts & ",", WS.CodeName & ",", vbTextCompare) = 0 Then
'Insert code to be looped here
Set Rng = WS.Range("C7", WS.Range("C1048576").End(xlUp))
For Each cel In Rng
If cel.Value = "0" Then
cel.EntireRow.Hidden = True
End If
Next cel
End If
'Next sheet
Next WS
I have been a silent reader on here for a few months but have been struggling with this code for a week now, so thought i would see if anyone can help.
I have a worksheet where sheet 1 contains information for users to input data.
Column A ask a question, column C is where the user will type in an answer.
Row 4 asks how many configurations there will be. depending on what number they input depends on how many cells light up to the right ie if 1 then D4 goes yellow, if 2 then D4 and E4 go yellow (using conditional formatting)
The user will then enter the title into the highlighted cell (D4,E4 ,F4 etc)
I want to create a new sheet at the end of the sheet for each configuration.
then NAME the new sheet by the text entered in D4, E4 etc.
the code I have so far is:
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 3 To Lastcol
If DoesSheetExist(ActiveSheet.Cells(4 & i).Value) Then
Set tmpSht = ActiveSheet.Cells(4 & i).Value
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(ws)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
I put in "NEWSHEET" to see if even creates a new sheet, but it still fails. I just cant see where I am going wrong.
Any help /advise is welcomed.
EDIT .
I cant work out why though.
The last col will be H4 so lastcol would be "8" .
Then for i = 4 to 8 run the loop. there are descriptions in each of the cells in row 4 so i don't see why it would work for 2 instantness and then fail ?
I dont know if this would make it easier but I have the number of sheets i want to create in cell C4 so i could use this rather than looking up populated cells. so if C4 is 2 then I want to add 2 sheets named as the content of D4, E4. if C4 is 3 then I want to add 3 sheets names as content of D3,E3,F3. Am I making this harder than I need too ?
UPDATE
I figured out the copying over of info is affecting this loop. and amended the code to this.
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
.Rows(13).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
this is doing what i want it to do with a couple of small exceptions.
the Sheets are being named by the cells in D1 , then E13,F13,G13,H13 So i need to figure out where that info is coming from.
the final bit is that due to my conditional formatting in the First sheet, I am getting text on black backgrounds in the copy cells, but that is the very least of my worries !
UPDATE
Found the error -
sShtName = ActiveSheet.Cells(4, i).Value2
should be
sShtName = Worksheets(1).Cells(4, i).Value2
You are calling your cells incorrectly. Use (4, i) instead of (4 & i).
The way you were calling it concatenated it to 43, which resulted in you checking cell AQ1 (AQ being the 43rd column) for the sheet reference.
Edit: I just walked through it a bit and found a couple of other errors. You need to set the sheet name to sht in your 'exists' function, and I'm assuming you want to set tmpSht to a sheet, so you need to encase it in sheets(). Try this:
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
Instead of adding the new sheet and then setting the activesheet to the tmpsht you could use a shorter way (see below). And why did you set the ws if you don't use it....
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = .Cells(4, .Columns.Count).End(xlToLeft).Column
If (Lastcol < 4) Then
Exit Sub
End If
For i = 4 To Lastcol
If (DoesSheetExist(.Cells(4, i).Value2) = True) Then
Set tmpSht = Sheets(.Cells(4, i).Value)
Else
Set tmpSht = Sheets.Add After:=Sheets(Sheets.Count)
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then
DoesSheetExist = True
Else
DoesSheetExist = False
End If
End Function
This was my final code. There were a few tweaks, Firstly I added a formula in row 6 to shorten the name of row 4 to a 10 character name as I found the tab names were too long (hence the code for the naming refers to row 6. I also added some custom text to add into each sheet and some formatting
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer
Dim i As Integer
Dim j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column ' work with the template sheet
If Lastcol = 3 Then Exit Sub 'repeat these steps from the first config to the last
For i = 4 To Lastcol
sShtName = Worksheets(1).Cells(6, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName tmpSht.Name = sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1) ' Format the cell width in the new sheet
.Rows(13).Copy tmpSht.Rows(4)
tmpSht.Range("A1").Value = Worksheets(1).Cells(4, i).Value2
Range("A1").ColumnWidth = 30
Range("B1").ColumnWidth = 0
Range("C1").ColumnWidth = 30
Range("D1:K1").ColumnWidth = 10
Range("D4:J4").Font.Color = vbWhite ' format the colour of the text in the new sheet
Range("C1") = " " ' Negate info in cell C1
With Range("A1:M5") ' add borders
'Clear existing
.Borders.LineStyle = xlNone
'Apply new borders
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With Range("A1:C4") ' set colours for the new sheet
.Font.Color = vbBlack
.Interior.Color = vbWhite
End With
Range("D4:J4").Font.Color = vbWhite ' set colour of the numbers to white to show on black background
Range("A5") = "Unit cost in " & Worksheets(1).Cells(17, 3).Value2
Range("A6") = "CUSTOM TEXT ONE."
Range("A7") = "NOTE if quantity " & Range("D4").Value2 + 5 & " is ordered then total cost will be your unit cost for " & Range("D4").Value2 & " multiplied by " & Range("D4").Value2 + 5 & " .This applies up to the quantity of " & Range("E4").Value2 - 1
Range("A8") = "CUSTOM TEXT 2"
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
Excel - VBA
I was wondering how to find a word into a Excel range of rows using VBA. Ex. "word to be found", this is not just the cell value but a word into a string. For instance, the way to find the word "network" into the string "Need help to map network printer".
Sub SearchForSfb()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
'Start copying data to row 2 in Open (row counter variable)
LCopyToRow = 2
While Len(Range("E" & CStr(LSearchRow)).Value) > 0
'If value in column E = "word to be found", copy entire row to Open
If Range("E" & CStr(LSearchRow)).Value = "word to be found" Then
'Select row in Data to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into SFB in next row
Sheets("SFB").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
Sheets("SFB").Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Data to continue searching
Sheets("Data").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Use a simple loop
Sub Button1_Click()
Dim ws As Worksheet
Dim sh As Worksheet
Dim lstRw As Long
Dim rng As Range
Dim s As String
Dim c As Range
s = "* network *"
Set ws = Sheets("Data")
Set sh = Sheets("SFB")
With ws
lstRw = .Cells(.Rows.Count, "E").End(xlUp).Row
Set rng = .Range("E2:E" & lstRw)
End With
For Each c In rng.Cells
If c.Value Like s Then
c.EntireRow.Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
End Sub
Or you can use a filter macro
Sub FiltExample()
Dim ws As Worksheet, sh As Worksheet
Dim rws As Long, rng As Range
Set ws = Sheets("Data")
Set sh = Sheets("SFB")
Application.ScreenUpdating = 0
With ws
rws = .Cells(.Rows.Count, "E").End(xlUp).Row
.Range("E:E").AutoFilter Field:=1, Criteria1:="=*network*"
Set rng = .Range("A2:Z" & rws).SpecialCells(xlCellTypeVisible)
rng.EntireRow.Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilterMode = False
End With
End Sub
This is what I have already, and it works great in removing #N/As from the range. I am now looking to modify it to do the same thing for cells that contain 0.
Sub DeleteErrorRows()
Dim r As Range
Set r = Range("B:B").SpecialCells(xlCellTypeConstants, 16).EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub
Thanks :)
Try this. It autofilters your column and keeps rows that have the findMe value in your source worksheet. You can set it to 0 as I have in the example or to whatever else you want. It copies those rows (except for the header row) to the target sheet and then deletes them from the source sheet.
Note that this also finds the first empty row on the target sheet so that you can run it multiple times without overwriting what you've already moved to the target sheet.
Sub CopyThenDeleteRowsWithMatch()
Dim wb As Workbook
Dim ws As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim firstPasteRow As Long
Dim findMe As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
firstPasteRow = tgt.Range("B" & tgt.Rows.Count).End(xlUp).Row + 1
findMe = "0"
Set rng = ws.Range("B1:B" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="=" & findMe
With .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
.Copy tgt.Range("A" & firstPasteRow)
.Delete
End With
End With
' turn off the filters
ActiveSheet.AutoFilterMode = False
End Sub
Consider:
Sub DeleteZeroRows()
Dim r As Range, rTemp As Range, rB As Range
Set rB = Intersect(Range("B:B"), ActiveSheet.UsedRange)
Set r = Nothing
For Each rTemp In rB
If Not IsEmpty(rTemp) And rTemp.Value = 0 Then
If r Is Nothing Then
Set r = rTemp
Else
Set r = Union(r, rTemp)
End If
End If
Next rTemp
Set r = r.EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub