This code is trying to print just one worksheet called NQLD Print, then cycle through all the options in a data validation list in cell B2 on that worksheet:
Sub PrintAll()
Dim strValidationRange As String
Dim rngValidation As Range
On Error GoTo errhandler
Dim rngDepartment As Range
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
If (sh.Name = "NQLD PRINT") Then
' Turn off screen updating
Application.ScreenUpdating = False
' Identify the source list of the data validation
strValidationRange = Range("B2").Validation.Formula1
Set rngValidation = Range(strValidationRange)
' Set the value in the selection cell to each selection in turn
' and print the results.
For Each rngDepartment In rngValidation.Cells
Range("B2").Value = rngDepartment.Value
ActiveSheet.PrintOut
Next
Application.ScreenUpdating = True
Exit Sub
errhandler: MsgBox Err.Description
End If
Next
End Sub
I'm getting the error Method 'Range' of object '_Worksheet' failed.
Cycling through the worksheets does not automatically confer parentage to cell ranges referenced within the worksheets.
Reference sh for each worksheet's ranges.
strValidationRange = sh.Range("B2").Validation.Formula1
Set rngValidation = sh.Range(strValidationRange)
Alternately, use a With ... End With statement.
For Each sh In ActiveWorkbook.Worksheets
With sh
If (.Name = "NQLD PRINT") Then
' Turn off screen updating
Application.ScreenUpdating = False
' Identify the source list of the data validation
strValidationRange = .Range("B2").Validation.Formula1
Set rngValidation = .Range(strValidationRange)
' more stuff here
End If
Next sh
Note the .Name and .Range and not sh.Name and Range.
You need to place "sh." as a prefix to every occurrence of Range().
Related
I have a challenge... I have a range in Sheet Lookup with each possible value in Pivot table filter "Owner: Full Name".
The range with the names are Sheets "Lookup" Range B2:B98. (Problem 1: This range can change as it creates this list in a different code, how to set this to a dynamic range?)
Once it filters on that i.e. value in B2 it should copy this filtered pivot into a new sheet and name the sheet after the value in b2.
Then it should "deselect" the b2 item and go to filter on value in b3 and continue.
Problem 2: Setting the filter correctly to loop and filter on each single value in the new dynamic lookup range.
Here is what I have at the moment...
Option Explicit
Dim wb As Workbook, ws, ws1, ws2 As Worksheet, PT As PivotTable, PTI As
PivotItem, PTF As PivotField, rng As Range
Sub Filter_Pivot()
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
For Each rng In ws1.Range("B2:B98")
With PTF
.ClearAllFilters
For Each PTI In PTF.PivotItems
PTI.Visible = (PTI.Name = rng)
Next PTI
Set ws2 = Sheets.Add
ws1.Name = PTI
.TableRange2.Copy
ws2.Range("A1").PasteSpecial
End With
Next rng
End Sub
You might be able to avoid all this and use the PivotTable.ShowPages Method. It is optimized for this sort of operation.
Note:
"Owner: Full Name" must be in the page field area at the top.
You probably want to check the sheet names don't already exist. You could do an initial loop of sheet names that will be generated from pivot and try deleting them (wrapping inside an On Error Resume Next, attempt delete, On Error GoTo 0) to ensure they don't exist first. I have shown how to do this in the second example.
Info: PivotTable.ShowPages Method
Creates a new PivotTable report for each item in the page field. Each
new report is created on a new worksheet.
Syntax expression . ShowPages( PageField )
expression A variable that represents a PivotTable object.
[Optional parameter of pageField.]
Code:
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
This will produce a sheet for each possible value in the page field "Owner: Full Name". If you don't want all of them, simply hold a list of sheet names for sheets to keep, in an array, and loop over all sheets in workbook and if not in array then delete as shown below:
① Example of looping sheets and deleting if not in array:
Option Explicit
Public Sub GeneratePivots()
Dim keepSheets(), ws As Worksheet
keepSheets = Array("FilterValue1", "FilterValue2","Lookup","Copy") '<== List of sheet names to keep
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, keepSheets, 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
② Using a lookup sheet:
If you do want to still read in the sheets to keep from the Copy sheet then you can use the following (but be sure to include in the list in column B the sheet names Copy,Lookup, the filter values of interest, and any other sheet names you don't want deleted):
Code:
Option Explicit
Public Sub GeneratePivots()
Dim ws As Worksheet, lookups As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook.Worksheets("Lookup")
Set lookups = .Range(.Range("B2"), .Range("B2").End(xlDown))
If Application.WorksheetFunction.CountA(lookups) = 0 Then Exit Sub
keepSheets = lookups.Value
End With
Dim rng As Range
For Each rng In lookups
On Error Resume Next
Select Case rng.Value
Case "Lookup", "Copy" '<=Extend for sheets to keep listed in lookups that aren't generated by the pivot filtering
Case Else
ThisWorkbook.Worksheets(rng.Value).Delete
End Select
On Error GoTo 0
Next rng
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Application.WorksheetFunction.Index(keepSheets, 0, 1), 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Example run:
You may try something like this...
Sub Filter_Pivot()
Dim wb As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim PT As PivotTable
Dim PTF As PivotField
Dim rng As Range
Dim lr As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For Each rng In ws1.Range("B2:B" & lr)
PTF.ClearAllFilters
On Error Resume Next
PTF.CurrentPage = rng.Value
If Err = 0 Then
Set ws2 = Sheets(rng.Value)
ws2.Cells.Clear
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = rng.Value
End If
PT.TableRange2.Copy ws2.Range("A1")
End If
PTF.ClearAllFilters
Set ws2 = Nothing
On Error GoTo 0
Next rng
End Sub
I have a user form and on a click of a button it is supposed to access or open a user form. But every time code gets to that part,
Run-time error '424':
Object required
pops up. Here is my code:
If CheckSheet(TextBoxValue) = True Then
Sheets(TextBoxValue).Select
UserForm.Show
Else
Set Worksheet = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
Worksheet.Name = TextBoxValue
Dim label As Control
For Each label In UserForm.Controls
If TypeName(label) = "Label" Then
With ActiveSheet
i = i + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(lastRow, i).Value = label.Caption
End With
End If
Next
UserForm.Show
End If
Every time it gets to the part with UserForm.Show and For Each label In UserForm.Controls
I checked the spelling of the form multiple times already and it is very much the same.
You may have had something like this in mind:-
Sub TestCode()
Dim Ws As Worksheet ' "Worksheet" is a reserved word
Dim MyForm As UserForm1 ' "UserForm" is a reserved word
Dim MyLabel As Control ' "Label" is a reserved word
Dim C As Long ' better name for a column than "i"
Set MyForm = New UserForm1
If GetSheet(Ws) Then
For Each MyLabel In MyForm.Controls
If TypeName(MyLabel) = "Label" Then
With Ws ' true, Ws is the ActiveSheet but
' always use the same name for the same sheet
C = C + 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(LastRow, C).Value = MyLabel.Caption
End With
End If
Next
End If
MyForm.Show
End Sub
Private Function GetSheet(Ws As Worksheet) As Boolean
' return True if Ws didn't exist
Dim Ws As Worksheet
On Error Resume Next
Set Ws = Worksheets(TextBoxValue)
If Err Then ' Err = doesn't exist
Set Ws = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
Ws.Name = TextBoxValue
GetSheet = True
End If
End Function
Private Function TextBoxValue() As String
TextBoxValue = "MySheetName"
End Function
In order to test if a word is a "reserved" word, select it in your VB Editor and press F1. If MS Office uses it, don't argue.
I'm writing a macro in VBA for Excel. I want it to replace all worksheets except for a few. First there is a loop which deletes the unwanted sheets, and then comes another one which creates new sheets to repace them! On a first run, the macro removes unwanted sheets. However, if it is run again it seems to be unable to delete the sheets it previously created, which causes a name duplicity error.
(The rng variable is supposed to extend across the entire row but I haven't gotten to fixing that yet.)
Hope you guys can provide some insight, much appreciated!
sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
If Not Current.Name = "Data" Then
Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
' Define range for loop
Dim rng As Range, cell As Range
Set rng = Sheets("Data").Range("A5:M5")
' Loop through entire row, looking for employees
For Each cell In rng
If cell.Value = "Nummer" Then
' Make new chart for employee
With Charts.Add
.ChartType = xlLineMarkers
.Name = cell.Offset(-1, 1).Value
.HasTitle = True
.ChartTitle.Text = cell.Offset(-1, 1).Value
' Set data (dynamic) and x-axis (static) for new chart
.SetSourceData Source:=Sheets("Data").Range(cell.Offset(-2, 3), cell.Offset(7, 4))
.Axes(xlValue).MajorGridlines.Select
.FullSeriesCollection(1).XValues = "=Data!E4:E12"
' Add trendlines
.FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (DDE)"
.FullSeriesCollection(2).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (SDE)"
End With
' Chart is moved to end of all sheets
Sheets(cell.Offset(-1, 1).Value).Move _
after:=Sheets(Sheets.Count)
End If
Next cell
End Sub
No need to define the worksheet with the Worksheets()
Sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Worksheets
If Not Current.Name = "Data" Then
Current.Delete
End If
Next Current
Application.DisplayAlerts = True
End sub
The Following code (minor changes worked in my workbook), are you sure you have the names you put in the If in your Workbook ?
Anyway, I think it's better to use Select for multiple possible mathces
Sub Terminator()
Dim Current As Excel.Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Sheets
If Not (Current.Name = "Data") Then
ActiveWorkbook.Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
End Sub
Solution to the deletion is supplied by RGA, but in case you want to avoid several AND statements for each sheet that you want to retain, you can utilize a function similar to the isInArray below:
Sub Terminator()
Dim Current As Variant
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ThisWorkbook.Sheets
If Not isInArray(Current.Name, Array("Data")) Then
Current.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Function isInArray(theValue As String, vArr As Variant) As Boolean
Dim vVal As Variant
isInArray = False
For Each vVal In vArr
If LCase(vVal) = LCase(theValue) Then
isInArray = True
End If
Next
End Function
EDIT:
function that takes a worksheet name as argument, and returns a worksheet object of that name. If the name is allready taken, the existing sheet is deleted and a new one created:
'example of use:
'set newWorksheet = doExist("This new Sheet")
Function doExist(strSheetName) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTest As Worksheet
Dim nWs As Worksheet
Set wsTest = Nothing
On Error Resume Next
'Set wsTest = wb.Worksheets(strSheetName) 'commented out in Edit of Edit
Set wsTest = wb.Sheets(strSheetName) 'as a comment for one of the other threads reveal, the error could be the deletion of Worksheets, which would be a subgroup to Sheets of which graph sheets are no a part
On Error GoTo 0
If Not wsTest Is Nothing Then
Application.DisplayAlerts = False
wsTest.Delete
Application.DisplayAlerts = True
End If
'Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count)) 'Edit of Edit, the later call to Charts.Add does this for you
'doExist.Name = strSheetName 'Edit of Edit, no need to return anything
End Function
I need to activate a specific worksheet. The code is meant to create worksheets with a specif name. I need to paste something from a another worksheet into all these newly created worksheets. The code that I'm using is below. But I'm having a hard time activating the newly created worksheet to paste what I want.
Sub octo()
'Dim ws As Worksheet
Dim Ki As Range
Dim ListSh As Range
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\timesheet.xlsx")
With Worksheets("PPE 05-17-15")
Set ListSh = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
On Error Resume Next
For Each Ki In ListSh
If Len(Trim(Ki.Value)) > 0 Then
If Len(Worksheets(Ki.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value
'open template
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\octo_template.xls")
Range("A1:L31").Select
Selection.Copy
Worksheets(Ki.Value).Activate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
End If
End If
Next Ki
End Sub
Both Workbooks.Open and Worksheets.Add return references to the opened and added objects, which you can use to directly access and modify them - and in your case, to paste data.
Example:
Dim oSourceSheet As Worksheet
Dim oTargetSheet As Worksheet
Set oSourceSheet = Sheet1 'Set reference to any sheet, Sheet1 in my example
Set oTargetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSourceSheet.Range("A1:L31").Copy
oTargetSheet.Paste
Set oSourceSheet = Nothing
Set oTargetSheet = Nothing
I think that is what you need. As what been mentioned by chris, there is no need Activate or Select. Hope the following code solve your problem.
Option Explicit
Dim MyTemplateWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyTemplateWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Dim MyNewDataWorksheet As Worksheet
Dim CurrentRange As Range
Dim ListRange As Range
Sub AddWSAndGetData()
Set MyTemplateWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx")
Set MyTemplateWorksheet = MyTemplateWorkbook.Sheets("Template")
Set MyDataWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx")
Set MyDataWorksheet = MyDataWorkbook.Sheets("PPE 05-17-15")
Set ListRange = MyDataWorksheet.Range("B4:B" & MyDataWorksheet.Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
On Error Resume Next
For Each CurrentRange In ListRange
If Len(Trim(CurrentRange.Value)) > 0 Then
If Len(MyDataWorksheet(CurrentRange.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CurrentRange.Value
Set MyNewDataWorksheet = MyDataWorkbook.Sheets(ActiveSheet.Name)
MyNewDataWorksheet.Range("A1:L31").Value = MyTemplateWorksheet.Range("A1:L31").Value
If MyDataWorkbook.Saved = False Then
MyDataWorkbook.Save
End If
End If
End If
Next CurrentRange
MyTemplateWorkbook.Close (False) 'Close the template without saving
End Sub
I have a macro that copy/pastes a selection from one worksheet (Sheet1), to another worksheet (Notes). It works well. Now I want to first check if that worksheet exists. If it does not exist, I want to create it, then continue with the copy/pasting the selection.
When the "Notes" worksheet exists, the copy/paste works fine.
If the worksheet does not exist, it creates it, but the paste operation doesn't work. I don't get any errors. I have to rerun the macro and then the paste works (since the worksheet has already been created). Any ideas on what I missed?
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
When you do the Add, the activesheet becomes the new worksheet and your previous Selection is lost...............you must "remember" it before the Add:
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
Dim RtoCopy As Range
Set RtoCopy = Selection
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
RtoCopy.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Pay attention to the three lines referencing RtoCopy .
You have On Error Resume Next in your code. First time through it goes on its merry way. The second time through the Error check triggers the creation of the new tab.
On Error Resume Next is bad. Don't use it.
See this question for more information on solving your problem How to check whether certain sheets exist or not in Excel-VBA?
You should first activate and select the sheet and range to be copied. This works.
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Worksheets("Sheet1").Activate 'Activete "Sheet1"
Worksheets("Sheet1").Range("A1").Select 'Select the range to be copied
'Then copy selection
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
I suggest using Function for more re-usability:
A dirty and fast way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
Set ws = Sheets(wsName)
isWorksheetValid = True
Exit Function
ErrHndl:
isWorksheetValid = False
End Function
A correct but a bit slower way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
For Each ws in Sheets
If (UCASE(ws.Name) = UCASE(wsName)) Then
isWorksheetValid = True
Exit Function
End If
Next
ErrHndl:
isWorksheetValid = False
End Function
Now you need just use it like this:
If (isWorksheetValid(mySheetName) Then
' Add your code here
End If