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
Related
Trying to loop though the worksheets to apply the filter on date, and copy all the filtered data into a "Report" sheet.
Here is code, which loops only the first sheet ( USD) and not the second one (EUR).
Sub SheetLoop()
Dim Ws As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim Rng As Range
Dim CRng As Range
Dim DRng As Range
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.Name <> DestSh.Name Then
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
End If
Next Ws
End Sub
Since AdvancedFilter needs the filtered range headers, you cannot copy only part of the filtered range, but you can delete the first row of the copied range, except the first copied range (from first sheet):
Sub SheetLoop()
Dim Ws As Worksheet, wb As Workbook, DestSh As Worksheet
Dim Rng As Range, CRng As Range, DRng As Range, i As Long
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.name <> DestSh.name Then
i = i + 1
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
If i > 1 Then DRng.cells(1).EntireRow.Delete xlUp 'delete the first row of the copied range, except the first case
Set DRng = DestSh.Range("A" & DestSh.rows.count).End(xlUp).Offset(1) 'reset the range where copying to
End If
Next Ws
MsgBox "Ready..."
End Sub
I have around 30 sheets that I want this code to run in at the same time. I want to find "ABC" and delete the value of the cell next to it in all my worksheets.
I get my error from: Set rSearch = .**range**("A1", .range("A" & rows.count).end(x1up))
When I have specified "Sheet1" next to the "With" statement, it works, but I want this code to run on all my sheets.
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim sheetsarray As Sheets
Set sheetsarray = ActiveWorkbook.Sheets(Array("sheet1", "sheet2", "sheet3"))
sign12 = "ABC"
With sheetsarray
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
End Sub
This question is a lot like: How to search for a string in all sheets of an Excel workbook?
But in my opinion, it's a lot easier to understand how to make code run on additional sheets reading my code than the code from the link above.
Try this (compilation of the comments above ;-)
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim oWB As Workbook
Dim oWS As Worksheet
Set oWB = ThisWorkbook
sign12 = "ABC"
For Each oWS In oWB.Sheets
With oWS
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
Next oWS
End Sub
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 am trying to cycle through all worksheets apart from one called 'summary', looking down a range in column A until finding a value, then looking in another workbook and getting some data, pasting it in, then carrying on until the end of column A range. Then it should move onto the next worksheet and repeat the process. I have been able to execute the code within the loop successfully, but only on the active worksheet. I've tried various iterations of the 'for each' statements. The current way seems to loop through the worksheets but doesn't run the code.
How can i amend it so it works properly?
Sub GetFlows()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim dem1 As String
Dim WhereCell As Range
Dim ws As Excel.Worksheet
Dim iIndex As Integer
Dim valueRng As Range
Dim x As Long
Dim y As Long
Set rng = Range("A9:A200")
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "summary" Then
ws.Activate
For x = 1 To rng.Rows.Count
dem1 = rng.Cells(x).Value
If dem1 <> "" Then
Set WhereCell = ThisWorkbook.ActiveSheet.Range("A9:A200").Find(dem1, lookat:=xlPart)
Windows("GetFilenames v2.xlsm").Activate
Worksheets(dem1).Range("A1").CurrentRegion.Copy
WhereCell.Offset(, 2).PasteSpecial Paste:=xlPasteValues
Else
ThisWorkbook.Activate
End If
Next x
End If
Next ws
End Sub
You could avoid all the Activate and Select and qualify all your Range and Cells statemets inside by using With ws.
So after you loop through all your Worksheets in :
For Each ws In ThisWorkbook.Worksheets , you add With ws and all the objects inside are qualified with the ws object.
Code:
Option Explicit
Sub GetFlows()
Dim cell As Range
Dim dem1 As String
Dim WhereCell As Range
Dim ws As Worksheet
Dim valueRng As Range
Dim x As Long
Dim y As Long
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "summary" Then
For x = 9 To 200 ' run a loop from row 9 to 200
dem1 = .Range("A" & x).Value
If dem1 <> "" Then
Set WhereCell = .Range("A9:A200").Find(what:=dem1, LookAt:=xlPart)
If Not WhereCell Is Nothing Then
Workbooks("GetFilenames v2.xlsm").Worksheets(dem1).Range("A1").CurrentRegion.Copy
WhereCell.Offset(, 2).PasteSpecial xlPasteValues
End If
End If
Next x
End If
End With
Next ws
End Sub
Can you try this? This checks if the value is found.
Sub GetFlows()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim dem1 As String
Dim WhereCell As Range
Dim ws As Excel.Worksheet
Dim iIndex As Integer
Dim valueRng As Range
Dim x As Long
Dim y As Long
Set rng = Range("A9:A200") ' should specify a sheet here, presumably Summary?
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "summary" Then
For x = 1 To rng.Rows.Count
dem1 = rng.Cells(x).Value
If dem1 <> vbNullString Then
Set WhereCell = ws.Range("A9:A200").Find(dem1, lookat:=xlPart)
If Not WhereCell Is Nothing Then
Workbooks("GetFilenames v2.xlsm").Worksheets(dem1).Range("A1").CurrentRegion.Copy
WhereCell.Offset(, 2).PasteSpecial Paste:=xlPasteValues
End If
End If
Next x
End If
Next ws
End Sub
I need to consolidate multiple worksheets in to one worksheet while having a space left between each tab of consolidated information. Can anyone help with this? Below is the code I have but I'm missing something:
Sub CopyWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", _
vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as
'first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, _
rng.Columns.Count).Value = rng.Value
'move cursor to bottom on active range and insert row
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Offset(1, 0).Select
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
Maybe this is what you need:
For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then Exit For
Set rng = sht.Range(sht.Cells(2, 1), _
sht.Cells(rows.count, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet (skip one empty row)
trg.Cells(rows.count, 1).End(xlUp).Offset(2).Resize(rng.Rows.Count, _
rng.Columns.Count).Value = rng.Value
Next sht