I'm using the following vba originally provided by RBarryYoung. It's close but not quite there.
Sub quote()
' get the current selection
Dim rng As Range
Set rng = Selection
If rng Is Nothing Then
MsgBox "Nothing Selected", vbOKOnly, "Cannot Define Local Name"
Exit Sub
End If
' get the current worksheet
Dim wks As Worksheet
Set wks = rng.Worksheet
Sht = ActiveSheet.Name
xps = "!"
' get the name to define
Dim sNam As String
sNam = InputBox("Enter the Name to Define for this Sheet:", "Define Local Name")
If sNam = "" Then Exit Sub
' define a name local to this worksheet
wks.Names.Add sNam, Sht & rng.Address
End Sub
The issue is that the local "refer to" definition isn't properly formatted. It should be this
='VMware Servers'!$K$45
But the closest I've gotten is this:
="'VMware Servers'!$K$45"
And because of this, the value is off which breaks everything.
Related
I am able to rename the activesheet using the following code but need to combine this with (first) duplicating the original sheet:
Sub CopySheet()
Dim strName As String
strName = InputBox("Budget2")
If strName = "" Then
Beep
Exit Sub
End If
ActiveSheet.Copy
ActiveSheet.Name = strName
End Sub
Per the documentation for the Worksheet.Copy method, using it without specifying either the Before or After argument will create a new Workbook, containing only that Worksheet.
So, to add a copy of the ActiveSheet after the ActiveSheet in the same Workbook, you can just change ActiveSheet.Copy to ActiveSheet.Copy After:=ActiveSheet
Make sure you check if the new sheet name already exists.
Make sure you keep track of where the copied sheet appears eg. after the source sheet SourceSheet.Copy After:=SourceSheet so you can pick up it's index which is 1 after the source sheet's: Set NewSheet = ThisWorkbook.Sheets(SourceSheet.Index + 1).
Finally make sure to catch errors on renaming if user entered not allowed characters or too long sheet names.
So you would end up with something like:
Option Explicit
Public Sub CopySheet()
Dim InputName As String
InputName = Application.InputBox("Budget2", Type:=2) '2 = text: https://learn.microsoft.com/en-us/office/vba/api/excel.application.inputbox#remarks
' user pressed cancel or entered nothing
If (VarType(InputName) = vbBoolean And InputName = False) Or InputName = vbNullString Then
Beep
Exit Sub
End If
' check if new sheet name already exists
On Error Resume Next
Dim TmpWs As Object
Set TmpWs = ThisWorkbook.Sheets(InputName)
On Error GoTo 0
If Not TmpWs Is Nothing Then
MsgBox "The Sheet '" & InputName & "' already exists", vbCritical
Exit Sub
End If
Dim SourceSheet As Object
Set SourceSheet = ActiveSheet
SourceSheet.Copy After:=SourceSheet
Dim NewSheet As Object
Set NewSheet = ThisWorkbook.Sheets(SourceSheet.Index + 1)
On Error GoTo ERR_RENAME
NewSheet.Name = "InputName"
On Error GoTo 0
Exit Sub
ERR_RENAME:
MsgBox "Sheet could not be renamed.", vbCritical
Err.Clear
End Sub
I need help modifying a macro that matches the part number (Column C) between two sheets in different workbooks. Then it pastes the info from 'Original' sheet from the range P9:X6500 into the 'New' sheet into the range P9:X6500. The first sheet 'Original' in column C range C9:C6500 is the matching part number column. The 'New' sheet has the same column C with the part number to match. I only want match and paste the visible values.
I originally had this macro code which copy pastes only visible values from one workbook to another that I would like to modify it to match and copy paste:
Sub GetDataDemo()
Const FileName As String = "Original.xlsx"
Const SheetName As String = "Original"
FilePath = "C:\Users\me\Desktop\"
Dim wb As Workbook
Dim this As Worksheet
Dim i As Long, ii As Long
Application.ScreenUpdating = False
If IsEmpty(Dir(FilePath & FileName)) Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Else
Set this = ActiveSheet
Set wb = Workbooks.Open(FilePath & FileName)
With wb.Worksheets(SheetName).Range("P9:X500")
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy this.Range("P9")
On Error GoTo 0
End With
End If
ThisWorkbook.Worksheets("NEW").Activate
End Sub
Also here is what I want it to look like:
Original
NEW
I appreciate the help!
try the following where it copies the range from one sheet to the other. You can break up With wb.Worksheets(SheetName).Range("P9:X500") into With wb.Worksheets(SheetName) then use .Range("P9:X500").Copy this.Range("P9") inside the With statement. Avoid using names like i or ii or this and use something more descriptive. The error handling is essentially only dealing with Sheets not being present and i think better handling of that scenario could be done. Finally, you need to turn ScreenUpdating back on to view changes.
Option Explicit
Public Sub GetDataDemo()
Const FILENAME As String = "Original.xlsx"
Const SHEETNAME As String = "Original"
Const FILEPATH As String = "C:\Users\me\Desktop\"
Dim wb As Workbook
Dim this As Worksheet 'Please reconsider this name
Application.ScreenUpdating = False
If IsEmpty(Dir(FILEPATH & FILENAME)) Then
MsgBox "The file " & FILENAME & " was not found", , "File Doesn't Exist"
Else
Set this = ActiveSheet
Set wb = Workbooks.Open(FILEPATH & FILENAME)
With wb.Worksheets(SHEETNAME)
'On Error Resume Next ''Not required here unless either of sheets do not exist
.Range("P9:X500").Copy this.Range("P9")
' On Error GoTo 0
End With
End If
ThisWorkbook.Worksheets("NEW").Activate
Application.ScreenUpdating = True ' so you can see the changes
End Sub
UPDATE: As OP wants to match between sheets on column C in both and paste associated row information across (Col P to Col X) second code version posted below
Version 2:
Option Explicit
Public Sub GetDataDemo()
Dim wb As Workbook
Dim lookupRange As Range
Dim matchRange As Range
Set wb = ThisWorkbook
Set lookupRange = wb.Worksheets("Original").Range("C9:C500")
Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")
Dim lookupCell As Range
Dim matchCell As Range
With wb.Worksheets("Original")
For Each lookupCell In lookupRange
For Each matchCell In matchRange
If Not IsEmpty(matchCell) And matchCell = lookupCell Then 'assumes no gaps in lookup range
matchCell.Offset(0, 13).Resize(1, 9).Value2 = lookupCell.Offset(0, 13).Resize(1, 9).Value2
End If
Next matchCell
Next lookupCell
End With
ThisWorkbook.Worksheets("NEW").Activate
Application.ScreenUpdating = True
End Sub
You may need to amend a few lines to suit your environment e.g. change this to meet your sheet name (pasting to).
Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")
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().
I have an excel workbook in excel 2007 which has approx 110 separate worksheets.
I want to have a menu page where the user can say yes or no to the title of the worksheet they want and press a button to run a macro which will then select the worksheets which the user has said Y too and then print them to PDF as one single PDF and not loads of individual PDFs.
I currently have the following code which selects the worksheets and prints them. At present though when I select a PDF printer it prints but only to multiple PDFs and not one single PDF.
Sub Printselection()
Dim rng As Range
Dim wks As Worksheet
For Each rng In Sheets("RA Database").Range("Q6:Q119")
If Trim(rng.Value) <> "" Then
On Error Resume Next
Set wks = Nothing
Set wks = Sheets(rng.Value)
On Error GoTo 0
If wks Is Nothing Then
MsgBox "Sheet " & rng.Value & " does not exist"
Else
Application.Dialogs(xlDialogPrinterSetup).Show
wks.PrintOut
End If
End If
Next rng
End Sub
The hard copy I'm happy for it to work like this but we need for the PDF copy to collate.
I'm a VB newbie so any help really would be appreciated!!
In order to print all the sheets into on PDF file, you will need to store all the sheet names you want to print into an array and then use the following command.
Worksheets(printSheets).PrintOut Preview:=False, ActivePrinter:="Adobe PDF", PrintToFile:=True, PrToFileName:=PSFileName
where printSheets is the array holding the names of sheets you want to print
EDIT:
This will work for you
Sub Printselection()
Dim rng As Range
Dim wks As Worksheet
Dim arr() As String
Dim i As Long: i = 0
For Each rng In Sheets("RA Database").Range("Q6:Q119")
If Trim(rng.Value) <> "" Then
On Error Resume Next
Set wks = Nothing
Set wks = Sheets(rng.Value)
On Error GoTo 0
If wks Is Nothing Then
MsgBox "Sheet " & rng.Value & " does not exist"
Else
ReDim Preserve arr(i)
arr(i) = wks.Name
i = i + 1
End If
End If
Next rng
Dim printSheets As Variant
printSheets = arr
Worksheets(printSheets).PrintOut Preview:=False, ActivePrinter:="Adobe PDF", PrintToFile:=True, PrToFileName:=PSFileName
End Sub
I am running some VBa code in Excel to update multiple sheets, based on a list of sheets names.
Sub Test()
Dim ArrayOne As Variant
ArrayOne = ActiveSheet.Range("A8:A10")
Dim sheetsArray As Sheets
Set sheetsArray = ActiveWorkbook.Sheets(ArrayOne)
Dim target As Range
Dim sheetObject As Worksheet
' change value of range 'a1' on each sheet from sheetsArray
For Each sheetObject In sheetsArray
Set target = sheetObject.Range("A1")
target.Value = "Test"
Next sheetObject
End Sub
Here is my code, unfortuantly it errors: Type Mismatch on the following line of code
Set sheetsArray = ActiveWorkbook.Sheets(ArrayOne)
I'm understanding that you want to update the same cells in each worksheet, based on a list of worksheets that is contained in an Excel Range (A8:A10).
Try the following code:
Public Sub test()
Dim wks As Worksheet
Dim WksCell As Range
' Turn on inline Error Handling
On Error Resume Next
' Look at each cell within the range and obtain worksheet names
For Each WksCell In ActiveSheet.Range("A8:A10").Cells
' Attempt to reference the worksheet using this name
Set wks = Excel.Worksheets(WksCell.Value)
' Check if a "SubScript out of range" error occurred
' If so, it indicates that the sheet name does not exist
If Err.Number = 9 Then
' Set its style to Bad and move on
WksCell.Style = "Bad"
Err.Clear
Else
' For each worksheet, execute our logic
wks.Range("A1").Value = "Testing"
End If
' If any other error occurred, report it to the user and exit
If Err.Number <> 0 And Err.Number <> 9 Then
MsgBox "An error has occurred. Error #" & Err.Number & vbCr & _
Err.Description, vbCritical, "Error Encountered"
Set wks = Nothing
Exit For
End If
Next
' Return to normal error handling
On Error GoTo 0
Set wks = Nothing
End Sub
If you'd rather use it in a Macro then you can change the line
For Each WksCell In ActiveSheet.Range("A8:A10").Cells
to
For Each WksCell In Excel.Selection
which will use your current selection as the Worksheet list. Makes it more dynamic.
Hope that helps.