I have this working code that gets the value from "sheet1" column C to set it as sheet name and make a new worksheet and copies the "testscript" sheet.
My problem is I only need to copy that has the column value with "Y".
Here is my code:
Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet
For Each rcell In Range("C2:C500")
If rcell.Value <> "" Then
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(rcell) Then
MsgBox "This sheet already exists!"
Exit Sub
End If
Next
Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
Next rcell
Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet
For Each rcell In Range("C2:C500")
'if rcell has value and same row column J is equal to "Y"
If rcell.Value <> "" And Sheets("Sheet1").Cells(rcell.Row, 10).Value = "Y" Then
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(rcell) Then
MsgBox "This sheet already exists!"
Exit Sub
End If
Next
Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
Next rcell
I'd go as follows
Option Explicit
Sub main()
Dim rcell As Range
With Sheets("Sheet1") ' reference your "source" sheet for subsequent range explicit qualification
For Each rcell In .Range("C2:C500").SpecialCells(xlCellTypeConstants) ' loop through wanted range not empty cells with "constant" (i.e. not formulas) values
If UCase(.Cells(rcell.Row, 10)).Value = "Y" Then ' check current cell row column J value
If Not IsSheetThere(rcell.Value) Then 'check there's no sheet named after current cell value
Sheets("TestScript").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
End If
Next
End With
End Sub
Function IsSheetThere(shtName As String) As Boolean
On Error Resume Next 'avoid any error at following line to stop the routine
IsSheetThere = Worksheets(shtName).Name = shtName 'try getting a sheet with the passed name. this will throw an error if no sheet is found with that name
End Function
Related
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
I have a code that checks in a range if some cells are blank (empty or not). It gives me a message saying so. But, it seems not working well : the output message always says that there are some empty cells in the range (column A to H, until the last populated row) whereas it's the contrary (always data).
I precise that the layout of the range is a table! MsgBox(LastRow) is every time equal to the last row also..
Here is a part of the code:
Set sht = ThisWorkbook.Worksheets("SS upload")
Set StartCell = Range("A14")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
MsgBox (LastRow)
Set Rrng = Range("A14 : H" & LastRow)
For Each cell In Rrng
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in the file"
Else
MsgBox "All cells have values!"
End If
End Sub
Does anything seem wrong in this?
Thank you for your precious help! :)
Regards
Probably you are not realizing, that you are looking in a range(A14:H LAST Row) Thus, if you have 5 rows, then the range is still Range(A14:H5). And there, you have empty values.
Public Sub TestME()
Dim bIsEmpty As Boolean
Set sht = ThisWorkbook.Worksheets(2)
Set StartCell = Range("A14")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).row
MsgBox (LastRow)
Set Rrng = Range("A1 : H" & LastRow)
For Each cell In Rrng
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty Then
MsgBox "There are empty cells in the file"
Else
MsgBox "All cells have values!"
End If
End Sub
That's strange indeed because it also work sometimes. I mean the output message "All cells have value" is conformed to what's really in the file (no blanks at all) but sometimes not..
Here is my full code:
Sub empty_cells()
Dim sht As Worksheet
Dim Rrng As Range
Dim cell As Range
Dim LastRow As Long
Dim StartCell As Range
Dim bIsEmpty As Boolean
Set sht = ThisWorkbook.Worksheets("SS upload")
Set StartCell = Range("A14")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
MsgBox (LastRow)
Set Rrng = Range("A14 : H" & LastRow)
For Each cell In Rrng
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in the file"
Else
MsgBox "All cells have values!"
End If
End Sub
thanks for your support :)
I have different Sheets called :
"Champagne"
"Water"
"ChocoStrawb"
"Bronze"
"Silver"
"Gold"
"Platinum"
"PlPlus"
"Ambassador"
I have this code :
Sheets("water").Select
Dim rng As Range, cell_search As Range, del As Range
Set rng = Intersect(Range("A2:A4200"), ActiveSheet.UsedRange)
For Each cell_search In rng
If (cell_search.Value) = "Delete" Then
If del Is Nothing Then
Set del = cell_search
Else: Set del = Union(del, cell_search)
End If
End If
Next cell_search
On Error Resume Next
del.EntireRow.Delete
But It delete the row only in the sheet "Water" I want this to be effective in all sheets.
You could create a macro that runs through each worksheet in your workbook:
Sub AllWorkbooks()
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
For x = 4200 To 2 Step -1
If WS.Cells(x, 1).Value = "Delete" Then
WS.Rows(x).EntireRow.Delete
End If
Next x
Next WS
End Sub
Autofilter() will speed things up
you can start by a Sub that "handles" a passed worksheet object:
Sub DeleteRowsWithKeyword(sht As Worksheet, keyWord As String)
With sht '<--| reference passed sht
With .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column A range form row 1 (header) down to its last not empty row
.AutoFilter Field:=1, Criteria1:=keyWord '<--| filter cells with passed 'keyWord'
If Application.WorksheetFunction.Subtotal(103, .cells) > 1 Then .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete '<--| if any filtered cells other than header then delete their entore row
End With
.AutoFilterMode = False
End With
End Sub
and then you can have your "Main" sub exploit it
loop through ALL worksheets
Sub Main()
Dim sht As Worksheet
For Each sht In Worksheets
DeleteRowsWithKeyword sht, "Delete"
Next
End Sub
loop through all sheets with given names:
Sub Main()
Dim sheetNames As Variant, shtName As Variant
sheetNames = Array("Champagne", "Water", "ChocoStrawb", "Bronze", "Silver", "Gold", "Platinum", "PlPlus", "Ambassador") '<--| list all your relevant sheet names here
For Each shtName In sheetNames
DeleteRowsWithKeyword Sheets(shtName), "Delete"
Next
End Sub
I am struggling to get this code right. I need to create a new worksheet for every city that is listed in column A of my worksheet called "AllCities", but only if the name of that city doesn't already exist as a worksheet. Right now my code will run but it will still add new worksheets to the end and not name them, when it should only add the last couple cities listed in the column. My current code is below.
Sub CreateSheetsFromAList()
Dim MyCell As Range
Dim MyRange As Range
With Sheets("AllCities").Range("A2")
Set MyRange = Sheets("AllCities").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
On Error Resume Next
Sheets.ADD After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
If Err.Number = 1004 Then
Debug.Print MyCell.Value & "already used as sheet name"
End If
On Error GoTo 0
Next MyCell
End With
End Sub
I find it easier to just start working on the worksheet whether it is there or not. Judicious error control will pause processing when attempted on a non-existent worksheet and allow error control to create one.
Sub CreateSheetsFromAList()
Dim myCell As Range, myRange As Range
With Sheets("AllCities")
Set myRange = Sheets("AllCities").Range("A2")
Set myRange = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
For Each myCell In myRange
On Error GoTo bm_Need_Worksheet
With Worksheets(myCell.Value)
'work on the worksheet here
End With
Next myCell
End With
Exit Sub
bm_Need_Worksheet:
With Worksheets.Add(after:=Sheets(Sheets.Count))
'trap an error on bad worksheet name
On Error GoTo 0
.Name = myCell.Value
'prep the worksheet
.Cells(1, 1).Resize(1, 9).Formula = "=""fld ""&SUBSTITUTE(ADDRESS(1,COLUMN(), 4, 1), 1, """")"
With ActiveWindow
.Zoom = 80
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
End With
Resume
End Sub
The key here is the Resume statement on the trapped error. It brings code execution back to the line that threw the error and continues processing from there.
I require assistance with the following please:
I need to filter a Range A9 - A32 for any data in column G.
Then i need to copy the data, but only columns A - E & G to sheet 2.
then delete the filtered data and return back to non filtered view.
I have tried the following without success:
Dim shSrc As Worksheet
Dim shDst As Worksheet
Dim rSrc As range
Dim rDst As range
Dim range
Dim numCol As Long ' number of columns to copy
On Error GoTo EH
range = ("A:E,G:G")
' select source and dest sheets
Set shSrc = ActiveWorkbook.Worksheets("Active Snag List")
Set shDst = ActiveWorkbook.Worksheets("Snag History")
' Select initial rows
Set rSrc = shSrc.Cells(9, 7)
Set rDst = shDst.Cells(2, 1)
' loop over source
Do While rSrc <> ""
' Test Source row, Qty = 0 and Name is not blank
With rSrc
If .Offset(0, 2) = 0 And .Value <> "" Then
'Copy
.Resize(1, range).Copy rDst.Resize(1, range)
Set rDst = rDst.Offset(1, 0)
End If
End With
Set rSrc = rSrc.Offset(1, 0)
Loop
Exit Sub
EH:
MsgBox "Error " & Err.Description
Thank you in advance!
To get your code working , replace the IF section with this
If .Offset(0, 2) = 0 And .Value <> "" Then
'Copy
'Cells A:E
rDst.Resize(1, 5).Value = .EntireRow.Cells(1, 1).Resize(1, 5).Value
' Cell G
rDst.Offset(0, 6).Value = .Value
Set rDst = rDst.Offset(1, 0)
End If
Why not use Autofilter rather than looping through cells? It will me much faster. See this example.
CODE(TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim shSrc As Worksheet, shDst As Worksheet
Dim rDst As range, rng As range, rngtocopy As range
Dim lastrow As Long
On Error GoTo EH
'~~> Select source and dest sheets
Set shSrc = ThisWorkbook.Worksheets("Active Snag List")
Set shDst = ThisWorkbook.Worksheets("Snag History")
'~~> Select initial rows
Set rDst = shDst.Cells(2, 1)
With shSrc
'~~> Remove any filters
.AutoFilterMode = False
'~~> Get the last row of Col G
lastrow = .range("G" & .Rows.Count).End(xlUp).Row
With .range("A8:G" & lastrow)
'~~> Filter G Col for non blanks
.AutoFilter Field:=7, Criteria1:="<>"
'~~> Get the offset(to exclude headers)
Set rng = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Remove Col F from the resulting range
Set rngtocopy = Union(shSrc.range(Replace(rng.Address, "G", "E")), _
shSrc.range(Replace(rng.Address, "A", "G")))
'~~> Copy cells to relevant destination
rngtocopy.Copy rDst
'~~> Delete the filtered results
rng.EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Exit Sub
EH:
MsgBox "Error " & Err.Description
End Sub
SNAPSHOTS
Sheet 1 before the macro runs
Sheet 2 after the macro runs
Sheet 1 after the macro runs