I am looking for a way with VBA in excel to loop through spreadsheet. I found a lot of sites with recommendations on using a range function, but nothing specific enough that has solve the issues that I have. Macro will only work on current tab. It will not loop through.
Sub UpdateAll()
'
' UpdateAll Macro
'
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Update_OI
Next ws
End Sub
Sub Update_OI()
'
' Update_OI Macro
Dim rng As Range
For Colx = 3 To 81
Cells(10, Colx).Select
If ActiveCell.Offset(-8, 0) = "X" Then GoTo 4
If ActiveCell.Offset(-3, 0) = 0 Then GoTo 4
If ActiveCell.Value = vbNullString Then GoTo 4
If ActiveCell.Value <> vbNullString Then GoTo 1
1
goalvalue = Cells(70, Colx).Value
Range(Cells(69, Colx), Cells(69, Colx)).GoalSeek Goal:=goalvalue, ChangingCell:=Range(Cells(10, Colx), Cells(10, Colx))
4
Next Colx
End Sub
You can pass the sheet object to Update_OI, and try not to use Select/Activate - you can almost always avoid that, and doing so will make your code more robust.
Sub UpdateAll()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Update_OI ws
Next ws
End Sub
Sub Update_OI(ws as Worksheet)
Dim rng As Range, Colx As Long
For Colx = 3 To 81
Set rng = ws.Cells(10, Colx)
If rng.Offset(-8, 0).Value <> "X" And _
rng.Offset(-3, 0).Value <> 0 And _
Len(rng.Value) > 0 Then
goalvalue = ws.Cells(70, Colx).Value
ws.Cells(69, Colx).GoalSeek Goal:=goalvalue, _
ChangingCell:=ws.Cells(10, Colx)
End If
Next Colx
End Sub
Change your update all as below. It should work now.
Sub UpdateAll()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Select
Call Update_OI
Next ws
End Sub
Below code works
Public Sub main()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Cells(1, 2).Value = 11111
Next ws
End Sub
Try changing
Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets
Call Update_OI
Next ws
To
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Update_OI
Next ws
Or was it just copy paste formating problem. In this case I will remove my answer as it si no answer :).
Related
my code runs by copying a specific range of data from multiple sheets that are available on the workbook. But I want to skip a sheet called "Data Recap" so that the code only runs for the other sheets only
what should I add to my code?
Sub Copy_Data()
Dim ws As Worksheet, MasterSheet As Worksheet
Dim originalDestinationCell As Range, nextDestCell As Range
Dim firstGreyCell As Range, c As Range, e As Range, s As Range
Dim lastRow As Long, firstRow As Long, colToCheckLast As Long, i As Long
Dim isMain As Boolean
Set MasterSheet = Sheets("Form Rekap") 'where you want to put the copied data
Set originalDestinationCell = MasterSheet.Range("C6") 'the first cell the data will be copied to
Set nextDestCell = originalDestinationCell.Offset(-1, 0)
firstRow = 6
colToCheckLast = 7
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = MasterSheet.Name Then
Set firstGreyCell = ws.Range("C" & firstRow) 'Set first starting loop cell
lastRow = ws.Cells(ws.Rows.Count, colToCheckLast).End(xlUp).Row
isMain = True
For i = firstRow To lastRow
Set c = ws.Range("C" & i)
Set e = ws.Range("E" & i)
Set s = Nothing
If isMain Then
If c.Interior.Color = firstGreyCell.Interior.Color Then
If Not IsEmpty(c) Then
Set s = c
Else
isMain = False
End If
End If
Else
If c.Interior.Color = firstGreyCell.Interior.Color Then
If Not IsEmpty(c) Then
Set s = c
End If
isMain = True
Else
If Not IsEmpty(e) Then
Set s = e
End If
End If
End If
If Not s Is Nothing Then
Set nextDestCell = MasterSheet.Cells(nextDestCell.Row + 1, originalDestinationCell.Column)
nextDestCell.Interior.Color = s.Interior.Color
nextDestCell.Value = s.Value
End If
Next
End If
Next ws
End Sub
Few ways to do what you want:
Sub SkipSpecificWorksheet()
Dim ws As Worksheet
'Your version
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = MasterSheet.Name And Not ws.Name = "Data Recap" Then 'Add another condition
'Do stuffs to the worksheet
End If
Next ws
'Alternative
'Same logic as above, just different syntax
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> MasterSheet.Name And ws.Name <> "Data Recap" Then
'Do stuffs to the worksheet
End If
Next ws
'Another alternative using Select Statement
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case MasterSheet.Name, "Data Recap" 'List of worksheet to skip
Case Else
'Do stuffs to the worksheet
End Select
Next ws
End Sub
Process Worksheets With Exceptions
Option Explicit
Sub ProcessWorksheets()
Const ExceptionsList As String = "Form Recap,Data Recap"
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
' e.g.:
Debug.Print ws.Name
'Else ' is in the list; do nothing
End If
Next ws
End Sub
I am working on a project to clean up a couple hundred excel sheets for an specific import spec. The import process errors out if any rows have a specific value blank, so I'm looking to find the best way to delete all rows in the entire workbook if column C in that row is empty. I found this simple VBA code that works on the active sheet, but I need it to loop through all sheets in the workbook. Any suggestions on a better process so I don't have to run it >100 times?
Sub DelBlankRows()
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Delete the Rows of a Column's Blanks
Option Explicit
Sub DelRowsOfColumnBlanksTEST()
Const wsCol As Variant = "C" ' or 3
'Const wsCol As String = "C"
'Const wsCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In wb.Worksheets
DelRowsOfColumnBlanks ws, wsCol
Next ws
Application.ScreenUpdating = True
End Sub
Sub DelRowsOfColumnBlanks( _
ByVal ws As Worksheet, _
ByVal WorksheetColumnID As Variant)
If ws Is Nothing Then Exit Sub ' no worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim urg As Range: Set urg = ws.UsedRange
If urg.Rows.Count = 1 Then Exit Sub ' only one row
On Error Resume Next
Dim crg As Range: Set crg = ws.Columns(WorksheetColumnID)
On Error GoTo 0
If crg Is Nothing Then Exit Sub ' invalid Worksheet Column ID
Dim tcrg As Range: Set tcrg = Intersect(urg, crg)
' ... is only the same as 'Set tcrg = urg.Columns(WorkhseetColumnID)',...
' ... if the first column of the used range is column 'A'.
If tcrg Is Nothing Then Exit Sub ' no intersection
Dim drg As Range: Set drg = tcrg.Resize(tcrg.Rows.Count - 1).Offset(1)
tcrg.AutoFilter 1, "=" ' ... covers blanks: 'Empty', "=""""", "'"... etc.
' Note that although it contains the word 'Blanks',...
' ... 'SpecialCells(xlCellTypeBlanks)' only covers 'Empty'.
On Error Resume Next
Dim spcrg As Range: Set spcrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not spcrg Is Nothing Then
spcrg.EntireRow.Delete
'Else
' no 'visible' cells (to delete)
End If
ws.AutoFilterMode = False
End Sub
Option Explicit
Sub CleanWorkbook()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
DeleteRowsOfEmptyColumn sh, "C"
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub DeleteRowsOfEmptyColumn(sh As Worksheet, col as string)
Dim rowsToDelete As New Collection
Dim cell
For Each cell In Intersect(sh.UsedRange, sh.Columns(col))
If cell.Value = "" Then
rowsToDelete.Add cell.Row
End If
Next
Dim i As Integer
For i = rowsToDelete.Count To 1 Step -1
sh.Rows(rowsToDelete(i)).Delete
Next
End Sub
I've put a very basic error trap for any sheets with no values in C. You may need to improve this yourself.
Edit: Updated error trap
Sub DelBlankRows()
Dim sh As Worksheet
Application.ScreenUpdating = False
On Error GoTo Handle
For Each sh In ThisWorkbook.Worksheets
sh.Activate
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Cont:
Next sh
Application.ScreenUpdating = True
Exit Sub
Handle:
If Err.Number = 1004 Then Resume Cont
End Sub
I am pretty new to VBA and am having an issue with my code. I have different hotel names from cell B4 to B27. My goal is to create new worksheets and name each one with the hotel names (going down the list). I tried running the sub procedure below but I am getting an error. The error says:
"Run-time error '1004': Application-defined or object-defined error"
It refers to the line below my comment. Any thoughts on why this is occurring and how I can fix this?
Sub sheetnamefromlist()
Dim count, i As Integer
count = WorksheetFunction.CountA(Range("B4", Range("B4").End(xlDown)))
i = 4
Do While i <= count
' next line errors
Sheets.Add(after:=Sheets(Sheets.count)).Name = Sheets("LocalList").Cells(i, 2).Text
i = i + 1
Loop
Sheets("LocalList").Activate
End Sub
Here is something that I quickly wrote
Few things
Do not find last row like that. You may want to see THIS
Do not use .Text to read the value of the cell. You may want to see What is the difference between .text, .value, and .value2?
Check if the sheet exists before trying to create one else you will get an error.
Is this what you are trying?
Option Explicit
Sub sheetnamefromlist()
Dim ws As Worksheet, wsNew As Worksheet
Dim lRow As Long, i As Long
Dim NewSheetName As String
'~~> Set this to the relevant worksheet
'~~> which has the range
Set ws = ThisWorkbook.Sheets("LocalList")
With ws
'~~> Find last row
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range
For i = 4 To lRow
NewSheetName = .Cells(i, 2).Value2
'~~> Check if there is already a worksheet with that name
If Not SheetExists(NewSheetName) Then
'~~> Create the worksheet and name it
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = NewSheetName
End With
End If
Next i
End With
End Sub
'~~> Function to check if the worksheet exists
Private Function SheetExists(shName As String) As Boolean
Dim shNew As Worksheet
On Error Resume Next
Set shNew = ThisWorkbook.Sheets(shName)
On Error GoTo 0
If Not shNew Is Nothing Then SheetExists = True
End Function
My assumptions
All cells have valid values i.e which can be used for sheet names. If not, then you will have to handle that error as well.
Workbook (not worksheet) is unprotected
Try,
Sub test()
Dim vDB As Variant
Dim rngDB As Range
Dim Ws As Worksheet, newWS As Worksheet
Dim i As Integer
Set Ws = Sheets("LocalList")
With Ws
Set rngDB = .Range("b4", .Range("b4").End(xlDown))
End With
vDB = rngDB 'Bring the contents of the range into a 2D array.
For i = 1 To UBound(vDB, 1)
Set newWS = Sheets.Add(after:=Sheets(Sheets.Count))
newWS.Name = vDB(i, 1)
Next i
End Sub
Create Worksheets from List
The following will create (and count) only worksheets with valid names.
When the worksheet is already added and the name is invalid, it will be deleted (poorly handled, but it works.)
It is assumed that the list is contiguous (no empty cells).
The Code
Option Explicit
Sub SheetNameFromList()
Const wsName As String = "LocalList"
Const FirstCell As String = "B4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim ListCount As Long
ListCount = WorksheetFunction.CountA(ws.Range(FirstCell, _
ws.Range(FirstCell).End(xlDown)))
Dim fRow As Long: fRow = ws.Range(FirstCell).Row
Dim fCol As Long: fCol = ws.Range(FirstCell).Column
Dim i As Long, wsCount As Long
Do While i < ListCount
If addSheetAfterLast(wb, ws.Cells(fRow + i, fCol).Value) = True Then
wsCount = wsCount + 1
End If
i = i + 1
Loop
ws.Activate
MsgBox "Created " & wsCount & " new worksheet(s).", vbInformation
End Sub
Function addSheetAfterLast(WorkbookObject As Workbook, _
SheetName As String) _
As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = WorkbookObject.Worksheets(SheetName)
If Err.Number = 0 Then Exit Function
Err.Clear
WorkbookObject.Sheets.Add After:=WorkbookObject.Sheets(Sheets.count)
If Err.Number <> 0 Then Exit Function
Err.Clear
WorkbookObject.ActiveSheet.Name = SheetName
If Err.Number <> 0 Then
Application.DisplayAlerts = False
WorkbookObject.Sheets(WorkbookObject.Sheets.count).Delete
Application.DisplayAlerts = False
Exit Function
End If
addSheetAfterLast = True
End Function
I have this function that removes the allow edit range from Excel, but I keep on getting an error indicating that method delete of object alloweditrange failed
Sub RemoveUserEditRange()
Dim ws As Worksheet, rng As Range, aer As AllowEditRange
Set ws = ThisWorkbook.Sheets("Protection")
ws.Unprotect
For Each aer In ws.Protection.AllowEditRanges
aer.Delete
Next
End Sub
Are you sure you have that range?
Try this
Sub RemoveUserEditRange()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Protection")
With ws
.Unprotect
With .Protection
If .AllowEditRanges.Count = 0 Then
MsgBox "Nothing to delete"
Else
'~~> Check if there is actually a range
Do While .AllowEditRanges.Count > 0
.AllowEditRanges(1).Delete
Loop
End If
End With
.Protect '<~~ ???
End With
End Sub
Try selecting your sheet before the loop :
ws.Select
The idea is I want to evaluate each Ws in Workbook for a given criteria in vba. If the criteria is met I want it to do something. If it's not met I want to go to the next ws. I know this is simple stuff. Any help would be really appreciate
Here's what I have so far.
Sub dataconsol()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
If ActiveSheet.Range("B9").Value = 1 Then
Range("A1").Value = 2
ElseIf Range("b9").Value <> 1 Then
End If
Next Ws
End Sub
Your code is fine. Switch ActiveSheet to With Ws as in your case ActiveSheet was always 'Sheet1'.
Sub dataconsol()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
With Ws
If .Range("B9").Value = 1 Then
.Range("A1").Value = 2
ElseIf .Range("b9").Value <> 1 Then
End If
End With
Next Ws
End Sub
Or if you want to use ActiveSheet:
Sub dataconsol2()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
Ws.Activate
If Range("B9").Value = 1 Then
Range("A1").Value = 2
ElseIf Range("b9").Value <> 1 Then
End If
Next Ws
End Sub