I have some code here but I'd like it to skip worksheets names Aggregated, Collated Results, Template, End. I have tried to add an If statement in to skip these but it doesn't seem to like it.
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
For Each ws In Worksheets
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
on error goto 0
if not rng1 is nothing then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
end if
Next ws
End Sub
If you add the names of the sheets you want to skip to the line worksheetsToSkip = array("... (below), then the code below should skip said sheets.
Option Explicit
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim worksheetsToSkip As Variant
worksheetsToSkip = Array("Aggregated", "Collated Results", "Template", "End")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng1 Is Nothing Then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
End If
End If
Next ws
End Sub
Related
I am trying to create user form (like on picture) from where I would choose 2 excel files and execute Vlookup. I
I try this code but it does not execute Vlookup.
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Option Explicit
Dim FileToOpen1 As Variant
Dim FileToOpen2 As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Private Sub BrowseButton1_Click()
FileToOpen1 = Application.GetOpenFilename(Title:="Browse for your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen1 <> False Then
TextBox1 = FileToOpen1
End If
End Sub
Private Sub BrowseButton2_Click()
FileToOpen2 = Application.GetOpenFilename(Title:="Browse foy your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen2 <> False Then
TextBox2 = FileToOpen2
End If
End Sub
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
On Error Resume Next
rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").row
Price_clm = wb1.Sheets(1).Range("C3").column
rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
wb1.Sheets(1).Cells(Price_row, Price_clm) = Application.WorksheetFunction.VLOOKUP(cl, rng2, 2, False)
Price_row = Price_row + 1
Next cl
End Sub
You are missing two variable definitions:
Dim Price_row As Long
Dim Price_clm As Long
And variables for range need to be assigned with Set
This: Set rng2 = wb2.Sheets(1).Range("A3:C8") instead of this rng2 = wb2.Sheets(1).Range("A3:C8")
Now, vlookup function in vba will throw an error when it doesnt find a value.
A workaround for this will be something like this.
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
Set rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").Row
Price_clm = wb1.Sheets(1).Range("C3").Column
Set rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
On Error Resume Next
vlResult = "" 'Reset variable
vlResult = Application.WorksheetFunction.VLookup(cl, rng2, 2, False) 'Performs vlookup
If Not vlResult = "" Then
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = vlResult
Else
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = "N/A"
End If
Price_row = Price_row + 1
Next cl
End Sub
*Dont forget to add the variable too.
Dim vlResult As String
I would like to automatically create sheets based on a list in sheet "Clients". This sheet has the names of clients (starting from cell A2) and the VBA code is reading this list and creates a sheet per cell value.
I found some code on this forum but it throws a 'Run-time error 450: Wrong number of arguments or invalid property assignment' on row 9 (Set MyRange2 = .Range(MyRange, .Rows.Count, "A").End(xlUp)). I'm not a VBA developer so searching for this error didn't really mean a lot to me. What could be wrong with this code?
Sub insertSheets()
Dim myCell As Range
Dim MyRange As Range
Dim MyRange2 As Range
With Sheets("Clients")
Set MyRange = .Range("A2")
Set MyRange2 = .Range(MyRange, .Rows.Count, "A").End(xlUp)
End With
For Each myCell In MyRange2
If Not myCell.Value = vbNullString Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = myCell.Value
End If
Next myCell
End Sub
Thanks for the help
Add Worksheets From a List
The Mistake
Set MyRange2 = .Range(MyRange, .Cells(.Rows.Count, "A").End(xlUp))
' or (no need for 'Set MyRange = .Range("A2")'):
'Set MyRange2 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
An Improvement
Option Explicit
Sub InsertSheets()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Clients")
Dim srg As Range
Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
Dim sCell As Range
Dim sValue As Variant
Dim dws As Worksheet
Dim wsCount As Long
Dim ErrNum As Long
For Each sCell In srg.Cells
sValue = sCell.Value
If Not IsError(sValue) Then ' ignore error values
sValue = CStr(sValue)
If Len(sValue) > 0 Then ' ignore blanks
On Error Resume Next
Set dws = ThisWorkbook.Worksheets(sValue)
On Error GoTo 0
If dws Is Nothing Then
Set dws = ThisWorkbook.Worksheets.Add( _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
On Error Resume Next
dws.Name = sValue
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then ' valid name
wsCount = wsCount + 1
Else ' invalid name; delete the worksheet
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
' Else ' worksheet already exists; do nothing
End If
Set dws = Nothing
' Else ' is blank; do nothing
End If
' Else ' is error value; do nothing
End If
Next sCell
MsgBox "Worksheets created: " & wsCount
End Sub
This question already has answers here:
Excel VBA, getting range from an inactive sheet
(3 answers)
Closed last year.
I'm trying to iterate through worksheets and find cells that have a font size of 22. Here is what I have so far, however I keep returning the value of the first found term over and over again as it iterates through the sheets. I'm assuming I'll need to incorporate a FindNext in there somewhere?
Sub FindFormatCell()
Dim ws As Worksheet
Dim rngFound As Range
With Application.FindFormat.Font
.Size = 22
End With
For Each ws In Worksheets
If ws.Tab.ColorIndex = 20 And ws.Visible = xlSheetVisible Then
Set rngFound = Cells.Find(What:="", SearchFormat:=True)
Debug.Print rngFound
End If
Next ws
Application.FindFormat.Clear
End Sub
The Find Method - A SearchFormat Search
Option Explicit
Sub FindFormatCell()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.FindFormat.Font.Size = 22
Dim ws As Worksheet
Dim sCell As Range
Dim srg As Range
Dim urg As Range
Dim FirstAddress As String
For Each ws In wb.Worksheets
If ws.Visible = xlSheetVisible And ws.Tab.ColorIndex = 20 Then
Set srg = ws.UsedRange
' "" - empty cells, "*" - occupied cells
Set sCell = srg.Find(What:="", _
After:=srg.Cells(srg.Rows.Count, srg.Columns.Count), _
LookIn:=xlValues, SearchOrder:=xlByRows, SearchFormat:=True)
If Not sCell Is Nothing Then
FirstAddress = sCell.Address
Do
If urg Is Nothing Then
Set urg = sCell
Else
Set urg = Union(urg, sCell)
End If
Set sCell = srg.FindNext(sCell)
Loop Until sCell.Address = FirstAddress
End If
If Not urg Is Nothing Then
' Start doing stuff here.
Debug.Print ws.Name, urg.Address(0, 0)
' End doing stuff here.
Set urg = Nothing
End If
End If
Next ws
Application.FindFormat.Clear
End Sub
I have a code that builds up and selects the range to copy it over to another worksheet in another sub.
Sub SelectREZ()
'Disable screen update
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Declare variables
Dim c As Range, ws As Worksheet
Dim rngG As Range, lastJ, rngJ As Range
Set ws = ActiveSheet
For Each c In Intersect(ws.UsedRange, ws.Columns("C"))
Set rngJ = c.EntireRow.Columns("J")
If c = "REZ" Then
AddRange rngG, c.EntireRow
'Remember the "ITEM NO."
lastJ = rngJ.Value
Else
If Len(lastJ) > 0 Then
If rngJ.Value Like lastJ & "*" Then
AddRange rngG, c.EntireRow
Else
lastJ = ""
End If
End If
End If
Next c
rngG.Select
End Sub
'Utility sub for building up a range
Sub AddRange(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
'Disable screen update
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
And I've ran into a situation when the range is empty and macro dies on the line
rngG.Select
How do I prevent such macro crash and quit the sub if range to select is empty?
I mean I could do:
On Error Resume Next
rngG.Select
But it seems like a sledgehammer way to approach it.
How can I change this code so it runs on all sheets of a workbook? It works well, just need it to run on all sheets. =)
Option Explicit
Option Compare Text
Sub HideColumns()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data")
Dim MyCell As Range
Dim HideMe As Range
Application.ScreenUpdating = False
For Each MyCell In ws.Range("A2:EA2")
If MyCell <> "First Name" And MyCell <> "Age" And MyCell <> "Gender" Then
If HideMe Is Nothing Then
Set HideMe = MyCell
Else
Set HideMe = Union(HideMe, MyCell)
End If
End If
Next MyCell
If Not HideMe Is Nothing Then
HideMe.EntireColumn.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
Loop through sheets using For Each loop & reset HideMe to Nothing before moving to next sheet.
Option Explicit
Option Compare Text
Sub HideColumns()
Dim ws As Worksheet 'Change made here
Dim MyCell As Range
Dim HideMe As Range
Application.ScreenUpdating = False
For Each ws in Worksheets 'and here
For Each MyCell In ws.Range("A2:EA2")
If MyCell <> "First Name" And MyCell <> "Age" And MyCell <> "Gender" Then
If HideMe Is Nothing Then
Set HideMe = MyCell
Else
Set HideMe = Union(HideMe, MyCell)
End If
End If
Next MyCell
If Not HideMe Is Nothing Then
HideMe.EntireColumn.Hidden = True
End If
Set HideMe = Nothing 'and here
Next ws 'and here
Application.ScreenUpdating = True
End Sub