In need of help in applying the following code below for all sheets. I have tried the code I found online which is ApplyToAllSheets() but I am still new and I don't know how I can make it work. Please help.
Sub ApplyToAllSheets()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
Third wks
Next
End Sub
Sub Third(wks As Worksheet)
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
With wks
Set Rng = .Range(.Range("B1"), .Range("B" & .Rows.Count).End(xlUp))
End With
'For deleting the remaining informations not necessary
Set Rng = Range("B1:B1000")
ContainWord = "-"
For Each cell In Rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
Set Rng = Range("C1:C1000")
ContainWord = "2019" 'change to current year
For Each cell In Rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
Set Rng = Range("A1:A1000")
ContainWord = "-"
For Each cell In Rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
'For deleting the blanks
On Error Resume Next
ActiveSheet.Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
On Error GoTo 0
'For shifting the date to the left
Columns("C").Cut
Columns("A").Insert Shift:=xlToLeft
Columns("C").Cut
Columns("B").Insert
'For deleting the negative sign "-"
With Columns("B:B")
.Replace What:="-", Replacement:=""
End With
End Sub
It should successfully apply the code to all the sheets
My result is that the first sheet was always cleared and the other sheets are untouched. please help
You've got unqualified - meaning the Worksheet isn't qualified - Range and Columns calls.
This is good - note the period in front of each instance of Range, as well as before Rows.
With wks
Set Rng = .Range(.Range("B1"), .Range("B" & .Rows.Count).End(xlUp))
End With
This, not so much:
Set Rng = Range("B1:B1000") ' no worksheet specified, so it's the ActiveSheet, not wks.
Or again:
Columns("C").Cut
Move that first End With all the way to the end of the Sub, and add a period in front of each instance of Range and Columns. By doing so, they will reference wks and not imply the ActiveSheet.
While you're at it, change that instance of ActiveSheet to wks. You want to work with wks, not the ActiveSheet.
Related
I have some data that has both words and values in cells and I am trying to delete the rows that don’t have values in the cells. My code works now if all of the numbers are negative but if there are positive numbers then my code won’t work. How do I fix this?
Sub tval
Dim s As Long
Dim LastRow As Long
S=2
LastRow= cells.find(“*”,[A1],,, xlByRows,xlPreviousRow).row
Do until s>LastRow
DoEvents
If InStr(1,Cells(s,4), “-“) > 0 Then
S=s+1
Else
Cells(s,4).EntireRow.Delete
LastRow=LastRow -1
End if
Loop
End sub
When deleting rows, you should always start from the end.
Sub tval
Dim s As Long
Dim LastRow As Long
LastRow= Cells(Rows.Count, 1).End(xlUp).Row
For s= LastRow to 2 Step -1
If Not IsNumeric(Cells(s,4)) then
Cells(s,4).EntireRow.Delete
End if
Next s
End sub
This should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rTextConstants As Range
Dim rTextFormulas As Range
Dim rCombined As Range
Set ws = ActiveWorkbook.ActiveSheet
'Exclude row 1 so that only text values found in rows 2+ are found
With ws.Range("A2", ws.Cells(ws.Rows.Count, ws.Columns.Count))
On Error Resume Next 'prevent error if no cells found
Set rTextConstants = .SpecialCells(xlCellTypeConstants, xlTextValues)
Set rTextFormulas = .SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0 'remove on error resume next condition
End With
If Not rTextConstants Is Nothing Then Set rCombined = rTextConstants
If Not rTextFormulas Is Nothing Then
If rCombined Is Nothing Then Set rCombined = rTextFormulas Else Set rCombined = Union(rCombined, rTextFormulas)
End If
If Not rCombined Is Nothing Then
rCombined.EntireRow.Delete
Else
MsgBox "No cells containing text found in sheet '" & ws.Name & "'", , "Error"
End If
End Sub
May I suggest a bit of a different approach:
Before:
Code:
Dim RNG1 As Range, RNG2 As Range
Option Explicit
Sub TestCase()
With ActiveWorkbook.Sheets(1)
Set RNG1 = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
If RNG1.SpecialCells(xlCellTypeConstants, 1).Count <> RNG1.Cells.Count Then
Set RNG2 = Application.Intersect(RNG1, RNG1.SpecialCells(xlCellTypeConstants, 2))
RNG2.EntireRow.Delete
End If
End With
End Sub
After:
You'll need to change this around to suit your range obviously. It should be a good starting point nonetheless.
You can also use AutoFilter to filter the numbers, and delete the visible cells to accomplish this task. The code accounts for a header row.
With ThisWorkbook.Sheets("Sheet1")
With .Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=4, Criteria1:="<>*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End With
I'm creating a ranking and I need to delete all the cells with #N/A (pasted as text, not formula) and to delete those cells and shhift them up.
The worksheet contains 503 raws and I need it from column A to T.
Thanks in advance, I have tried so many VBA codes of this web and I'm not able to find something that works.
Try,
dim rng as range
with worksheets("sheet1")
on error resume next
set rng = .range("A:T").specialcells(xlcelltypeformulas, xlerrors)
if not rng is nothing then
rng.delete shift:=xlup
end if
set rng = .range("A:T").specialcells(xlcelltypeconstants, xlerrors)
if not rng is nothing then
rng.delete shift:=xlup
end if
on error goto 0
end with
This should work. There are faster ways of doing what you ask, but since you don't have that big of a data set, I just modified some code I had available.
Sub KillPoundNa()
Dim rCell As Range, WS As Worksheet, KillRng As Range, UndesireableText As String
UndesireableText = "#N/A"
Set WS = ActiveSheet
Set KillRng = WS.Cells(Rows.Count, 1)
For Each rCell In WS.UsedRange.Cells
If InStr(1, rCell.Text, UndesireableText, vbTextCompare) > 0 Then
Set KillRng = Union(KillRng, rCell)
End If
Next rCell
KillRng.Delete (xlUp)
End Sub
In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow
Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
Sub SelectAllReleventText()
Do While Range(“A1”).Offset(1, 6) <> Empty
Rows(ActiveCell.Row).Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Here is my script, I've been told it doesn't do what it is meant to, which I expected since this was my first attempt. I am coming up with a variable not defined error. I thought I defined the variable, but I guess it wasn't specific enough for Excel VBA.
This is what I am attempting to do.
In Workbook 1, On B6 there is an alphanumeric name, I want that row to be selected.
Go down one row, if there is text there select that row.
Continue till text is no longer prevalent.
Copy selected rows.
Paste into another workbook (Workbook2), into tab 1, starting on row 2, since row 1 has headers.
Thanks in advance. Just a heads up, I am using the Options Explicit in my VBA because I was told it was the "right way to do thing"...
Yes using Option Explicit is a good habit. Using .Select however is not :) it reduces the speed of the code. Also fully justify sheet names else the code will always run for the Activesheet which might not be what you actually wanted.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim lastRow As Long, i As Long
Dim CopyRange As Range
'~~> Change Sheet1 to relevant sheet name
With Sheets("Sheet1")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
If CopyRange Is Nothing Then
Set CopyRange = .Rows(i)
Else
Set CopyRange = Union(CopyRange, .Rows(i))
End If
Else
Exit For
End If
Next
If Not CopyRange Is Nothing Then
'~~> Change Sheet2 to relevant sheet name
CopyRange.Copy Sheets("Sheet2").Rows(1)
End If
End With
End Sub
NOTE
If if you have data from Row 2 till Row 10 and row 11 is blank and then you have data again from Row 12 then the above code will only copy data from Row 2 till Row 10
If you want to copy all rows which have data then use this code.
Option Explicit
Sub Sample()
Dim lastRow As Long, i As Long
Dim CopyRange As Range
'~~> Change Sheet1 to relevant sheet name
With Sheets("Sheet1")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
If CopyRange Is Nothing Then
Set CopyRange = .Rows(i)
Else
Set CopyRange = Union(CopyRange, .Rows(i))
End If
End If
Next
If Not CopyRange Is Nothing Then
'~~> Change Sheet2 to relevant sheet name
CopyRange.Copy Sheets("Sheet2").Rows(1)
End If
End With
End Sub
Hope this is what you wanted?
Sid
The easiest way to do it is to use the End method, which is gives you the cell that you reach by pressing the end key and then a direction when you're on a cell (in this case B6). This won't give you what you expect if B6 or B7 is empty, though.
Dim start_cell As Range
Set start_cell = Range("[Workbook1.xlsx]Sheet1!B6")
Range(start_cell, start_cell.End(xlDown)).Copy Range("[Workbook2.xlsx]Sheet1!A2")
If you can't use End, then you would have to use a loop.
Dim start_cell As Range, end_cell As Range
Set start_cell = Range("[Workbook1.xlsx]Sheet1!B6")
Set end_cell = start_cell
Do Until IsEmpty(end_cell.Offset(1, 0))
Set end_cell = end_cell.Offset(1, 0)
Loop
Range(start_cell, end_cell).Copy Range("[Workbook2.xlsx]Sheet1!A2")