I am trying to get the user to enter sheet name and based on the input I want selected cell value to be copied from one sheet to another sheet to a new row.
This is for a basic excel functioning system
Set nextCellInColumn = Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
strName = Application.InputBox("Please enter")
nextCellInColumn.Value = Worksheets.Application.InputBox("Please enter").Range("I5").Value
Worksheets.Application.InputBox("Please enter").Range("I5").Copy Worksheets("Summary").Range("D6")
You need to test if the worksheet name exists that the user entered otherwise the copy will fail. Also if the user presses the Cancel button the InputBox will return a boolean False. You need to check for that and eg exit, or your code fails too.
Option Explicit
Public Sub Test()
Dim wsSummary As Worksheet
Set wsSummary = ThisWorkbook.Worksheets("Summary")
Dim NextCellInColumn As Range
Set NextCellInColumn = wsSummary.Cells(wsSummary.Rows.Count, 4).End(xlUp).Offset(1, 0)
Dim strName As Variant 'if user presses cancel it will return a boolean false
strName = Application.InputBox("Please enter")
If VarType(strName) = vbBoolean And strName = False Then Exit Sub 'user pressed cancel so exit
If WorksheetExists(strName) Then
NextCellInColumn.Value = ThisWorkbook.Worksheets(strName).Range("I5").Value
ThisWorkbook.Worksheets(strName).Range("I5").Copy wsSummary.Range("D6")
Else
MsgBox "Worksheet '" & strName & "' not found.", vbCritical
End If
End Sub
'check if a worksheet exists
Public Function WorksheetExists(ByVal WorksheetName As String, Optional ByVal wb As Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook 'default to thisworkbook
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(WorksheetName)
On Error GoTo 0
WorksheetExists = Not ws Is Nothing
End Function
Related
I am working on a Userform that will copy a specific sheet from Workbook A and paste it into Workbook B (essentially archiving that data). The Userform presents the user with a combo-box dropdown to select the sheet name to be copied. I receive a subscript out of range error however when using the sheets.copy command. Here is my code with names modified for ease of reading:
Dim ws as Worksheet
Dim WorkbookA as Workbook
Dim WorkbookB as Workbook
Dim ComboBoxValue as String
Set WorkbookA as ActiveWorkbook
Set WorkbookB as Workbook.Open("C:File Path Here")
With ThisWorkbook
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name = UserForm1.ComboBox1.Text Then
ComboBoxValue = ws.Name
Worksheets(ComboBoxValue).Copy _
After:=Workbooks("Workbook B.xlsm").Sheets(Sheets.Count)
' Run-Time 9 Subscript Out of Range Error occurs on line above ^
ActiveSheet.Name = UserForm1.ComboBoxSelection.Text
WorkbookB.Save
WorkbookB.Close
WorkbookA.Activate
Application.CutCopyMode = False
End If
Next ws
End With
The root of your error is improper refenceing of the workbook. There are a lot of other issues, too.
Unnecassary reference to ThisWorkbook
Unnecassary loop through all worksheets
Unnecassary renaming of copied sheet
Unnecassry / incorrect references to the ActiveWorkbook and ActiveSheet
No Error Handling
Improper indenting
Your code, refactored. This is written as a button click event in the UserForm. Update to suit your needs.
Option Explicit
Const ArchiveFilePath As String = "C:\Path\To\ArchiveBook.xlsx"
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim WorkbookA As Workbook
Dim WorkbookB As Workbook
Dim wsName As String
Application.ScreenUpdating = False
Set WorkbookA = ActiveWorkbook
wsName = UserForm1.ComboBox1.Text
If wsName = vbNullString Then Exit Sub
On Error Resume Next 'Handle possibility that Open fails
Set WorkbookB = Workbooks.Open(ArchiveFilePath)
On Error GoTo 0
If WorkbookB Is Nothing Then
MsgBox "Failed to open " & ArchiveFilePath, vbOKOnly, "Error"
Exit Sub
End If
'Check if specified ws already exists in WorkbookB
Set ws = GetWorksheet(WorkbookB, wsName)
If Not ws Is Nothing Then
' Sheet already exists. What now?
MsgBox "Sheet " & wsName & " already exists in " & WorkbookB.Name & ". What now?", vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
Set ws = GetWorksheet(WorkbookA, wsName)
If ws Is Nothing Then
MsgBox "Sheet " & wsName & " does not exist in " & WorkbookA.Name, vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
ws.Copy After:=WorkbookB.Sheets(WorkbookB.Sheets.Count)
WorkbookB.Save
WorkbookB.Close
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
On Error GoTo EH
Set GetWorksheet = wb.Worksheets(wsName)
EH:
End Function
Change Sheets(Sheets.Count) to Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)
In this context, Sheets(Sheets.Count) is referring to your source workbook object, so you must specify to count the sheets in the other book.
[table - worksheet "output - flat"][1]
I have code below that checks to see if column "NamedRange" in the table attached appears as a named range in the (dstRng) template and if it does exist it returns the value to the right ("report balance"). How can I add a condition where when the user chooses a template it will only return values based on the Ted ID - in the table attached. I have 2 templates and it loops through the two templates however I want the first template to only return values for Ted ID 10004 and template 2 it will only return values for Ted ID 11372 and etc. etc. Hope that makes sense... let me know if u have any questions
Option Explicit
Sub Button4_Click()
Dim Desktop As Variant
Dim Files As Object
Dim Folder As Variant
Dim oShell As Object
Dim Tmplts As Variant ' Templates folder
Dim wsLocal As Worksheet
Dim wsGroup As Worksheet
Dim wb As Object
' Check Box 2 "Select All" must be checked to run the macro.
If ActiveSheet.Shapes("Check Box 2").ControlFormat.Value = xlOff Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
' Prompt user to locate the Templates folder.
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Tmplts = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set oShell = CreateObject("Shell.Application")
Set Desktop = oShell.Namespace(0)
' Create the Output folder on the User's Desktop if it does not exist.
Set Folder = Desktop.ParseName("Output")
If Folder Is Nothing Then
Desktop.NewFolder "Output"
Set Folder = Desktop.ParseName("Output")
End If
Set Files = oShell.Namespace(Tmplts).Items
Files.Filter 64, "*.xlsm"
For Each wb In Files
Set wb = Workbooks.Open(Filename:=wb.Path, UpdateLinks:=False)
Call BreakLinks(wb)
On Error Resume Next
Set wsLocal = wb.Worksheets("RVP Local GAAP")
Set wsGroup = wb.Worksheets("RVP Group GAAP")
'unprotect workbook
wsLocal.Unprotect Password:="KqtgH5rn9v"
wsGroup.Unprotect Password:="KqtgH5rn9v"
On Error GoTo 0
' Check that both worksheets exist before updating.
If Not wsLocal Is Nothing And Not wsGroup Is Nothing Then
Call ProcessNamedRanges(wb)
'lock the workbook
wsLocal.Protect Password:="KqtgH5rn9v"
wsGroup.Protect Password:="KqtgH5rn9v"
''MsgBox "Ranges have been updated sucessfully."
' Save the workbook to the folder and close.
On Error Resume Next
wb.SaveAs Filename:=Folder.Path & "\" & wb.Name
ActiveWorkbook.Close True
On Error GoTo 0
End If
Next wb
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub ProcessNamedRanges(ByRef wb As Workbook)
Dim dstRng As Range
Dim rng As Range
Dim rngName As Range
Dim rngNames As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Output - Flat")
' Exit if there are no named ranges listed.
If wks.Range("D4") = "" Then Exit Sub
Set rngNames = wks.Range("D4").CurrentRegion
Set rngNames = Intersect(rngNames.Offset(1, 0), rngNames.Columns(2))
'Loop through all the values in NamedRange
For Each rngName In rngNames
' Verify the Named Range exists.
On Error Resume Next
Set dstRng = wb.Names(rngName.Text).RefersToRange
If Err = 0 Then
'Copy the report balance to the Template worksheet in column "G".
dstRng.Value = rngName.Offset(0, 1).Value
Else
'answer = MsgBox("The Named Range """ & rngName.Value & """ Does Not Exist" & vbLf & vbLf & "Continue?", vbYesNo + vbExclamation)
'If answer = vbNo Then Exit Sub
End If
On Error GoTo 0
Next rngName
End Sub
Sub BreakLinks(ByRef wb As Workbook)
Dim i As Long
Dim wbLinks As Variant
wbLinks = wb.LinkSources(xlExcelLinks)
If Not IsEmpty(wbLinks) Then
For i = 1 To UBound(wbLinks)
ActiveWorkbook.BreakLink wbLinks(i), xlLinkTypeExcelLinks
Next i
End If
End Sub
I am using the below code to rename worksheet.
Option Explicit
Sub RenWSs()
Dim ws As Worksheet
Dim shtName
Dim newName As String
Dim i As Integer
Dim RngStr As String
RngStr = Application.InputBox(prompt:="Select the Range for the new Sheet's name", Type:=2)
For Each ws In Worksheets
With ws
If Trim(.Range(RngStr)) <> "" Then
shtName = Split(Trim(.Range(RngStr)), " ")
newName = shtName(0)
On Error GoTo ws_name_error
.Name = .Range(RngStr)
GoTo done
repeat:
.Name = newName & i
GoTo done
ws_name_error:
i = i + 1
Resume repeat
End If
End With
On Error GoTo 0
done:
Next
End Sub
In this i am selecting the new name through Input Box and its working fine. Now what i want is, before calling the input box, the below process has to be done.
I have names in drop down list, each names in drop down list to be updated one by one in all worksheets like J16 is the cell.
Please help me
The code below will lopp through all ws sheets, and modifies the value of cell in "J16" to "Test 1" (just for testing purposes).
Option Explicit
Sub ModifyDropDownValue()
Dim ws As Worksheet
For Each ws In Worksheets
With ws
' modify the value in cell J16
.Range("J16").Value = "Test 1"
End With
Next ws
End Sub
I have a two excel spreadsheets i need to copy a worksheets with its data and paste it to another workbook.
while executing the code its not copying the sheet to another workbook. If i modified my code and excute thrice or twice its copying twice in target workbook.
Can someone help me out.
Code:
Dim filter As String
Dim caption As String
Dim RB_Filename As String
Dim RB_workbook As Workbook
Dim Master_workbook As Workbook
Dim RB_sheet As Worksheet
Dim Master_sheet As Worksheet
Dim errSheet As Worksheet
Dim errSheetExists As Boolean
Dim StatusSheet As Worksheet
Dim sourceStatusSheet As Worksheet
Set Master_workbook = Application.ActiveWorkbook
' get the workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
MsgBox "Please insert file "
RB_Filename = Application.GetOpenFilename(filter, , caption)
'If Cancel then exit
If TypeName(RB_Filename) = "Boolean" Then
Exit Sub
End If
Set RB_workbook = Workbooks.Open(RB_Filename
Set RB_sheet = RB_workbook.Worksheets("Holger")
RB_sheet.Activate
RB_sheet.Select
For Each sourceStatusSheet In Master_workbook.Worksheets
If sourceStatusSheet.Name = "Holger" Then
Windows(Master_workbook.Name).Activate
Master_workbook.Sheets(sourceStatusSheet.Name).Select
'Worksheets(i).Cells.ClearContents
sourceStatusSheet.Delete
RB_sheet.Copy After:=Master_workbook.Sheets(Master_workbook.Sheets.Count)
Master_workbook.Activate
Exit For
End If
Next
If TypeName(RB_sheet) = "Boolean" Then
Exit Sub
End If
RB_workbook.Close
End Sub
Sometimes it is best to simply try and .Delete something whether it exists or not. On Error Resume Next can skip over trying to delete something that doesn't exist and Application.DisplayAlerts can skip any annoying confirmations if it does.
Sub ws_Copy()
Dim filter As String
Dim caption As String
Dim RB_Filename As String
Dim RB_workbook As Workbook
Dim Master_workbook As Workbook
Dim RB_sheet As Worksheet
Dim Master_sheet As Worksheet
Dim errSheet As Worksheet
Dim errSheetExists As Boolean
Dim StatusSheet As Worksheet
Dim sourceStatusSheet As Worksheet
Set Master_workbook = ActiveWorkbook
' get the workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
MsgBox "Please insert file "
RB_Filename = Application.GetOpenFilename(filter, , caption)
'If Cancel then exit
If TypeName(RB_Filename) = "Boolean" Then Exit Sub
Set RB_workbook = Workbooks.Open(RB_Filename, ReadOnly:=True)
Set RB_sheet = RB_workbook.Worksheets("Holger")
With Master_workbook
'first remove the Holger ws from Master (if it exists)
On Error Resume Next
Application.DisplayAlerts = False
.Worksheets("Holger").Delete
Application.DisplayAlerts = True
On Error GoTo 0
'copy the Holger ws to Master
RB_sheet.Copy After:=.Sheets(.Sheets.Count)
End With
RB_workbook.Close savechanges:=False
End Sub
I have a code that asks the user to select a sheet by writing its name in an inputbox, and then I need to check if the selected name is correct.
How can I write the "if" statement so to return back to the inputbox?
I'm using MS Word in Windows 7. This is the code:
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Sub OpenExcelFile()
Dim oExcel As Excel.Application
Dim oWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim oneRange As Excel.Range
Dim aCell As Excel.Range
Dim intChoice As Integer
Dim strPath As String
Dim uiSheet As String
Set oExcel = New Excel.Application
'Select the start folder
Application.FileDialog(msoFileDialogOpen _
).InitialFileName = ActiveDocument.path
'Remove all other filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
'Add a custom filter
Call Application.FileDialog(msoFileDialogOpen).Filters.Add( _
"Only Excel File Allowed", "*.xl*")
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
End If
'open excel file and select sheet
Set oWB = oExcel.Workbooks.Open(strPath)
Dim strBuild As String
'set Array for user input control
Dim myArray() As Variant
ReDim myArray(1 To oWB.Sheets.Count)
'populate input box and array
For Each xlSheet In oWB.Worksheets
strBuild = strBuild & xlSheet.Name & vbCrLf
For i = 1 To oWB.Sheets.Count
myArray(i) = oWB.Sheets(i).Name
Next i
Next xlSheet
'show inputbox with list of sheets
strBuild = Left$(strBuild, Len(strBuild) - 2)
uiSheet = InputBox("Provide a sheet name." & vbNewLine & strBuild)
'check if User input match with sheet name
If IsInArray(uiSheet, myArray) Then
'show excel window
oExcel.Visible = True
'sort selected sheet by first column range
oExcel.Worksheets(uiSheet).Activate
Set oneRange = oExcel.Range("A1:A150")
Set aCell = oExcel.Range("A1")
oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Else
MsgBox "Please enter a valid name!", vbCritical
End If
End Sub
If you replace the code starting with uiSheet = InputBox(..... with the code below, it should work.
'check if User input match with sheet name
Dim bSheetPresent As Boolean
bSheetPresent = False
Do Until bSheetPresent
uiSheet = InputBox("Provide a sheet name." & vbNewLine & strBuild)
If uiSheet = "" Then Exit Do
If IsInArray(uiSheet, myArray) Then
bSheetPresent = True
Else
MsgBox "Please enter a valid name!", vbCritical
End If
Loop
If bSheetPresent Then
'show excel window
oExcel.visible = True
'sort selected sheet by first column range
oExcel.Worksheets(uiSheet).Activate
Set oneRange = oExcel.Range("A1:A150")
Set aCell = oExcel.Range("A1")
oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
End If
If the user presses cancel on the inputbox, the it will exit the loop.
You may also consider to build a form with a pre-filled combobox. That way the user cannot make a mistake.
To create create your own inputbox with a list of sheets, you can do this:
Create a userform in the VBE
Name it frmSelectSheet
Put a combobox on it named cbSheets
Add the following code to the userform's code pane:
Private Sub UserForm_Initialize()
Dim oSheet As Worksheet
For Each oSheet In ThisWorkbook.Sheets
Me.cbSheets.AddItem oSheet.Name
Next oSheet
End Sub
Private Sub cbSheets_Change()
Me.Hide
End Sub
Add a module and add the following code to it:
Public Function SheetInputBox() As String
Dim ofrmSheetInput As New frmSelectSheet
ofrmSheetInput.Show
SheetInputBox = ofrmSheetInput.cbSheets
Unload ofrmSheetInput
End Function
Call the function like this
? SheetInputBox or uiSheet = SheetInputBox