Save Worksheets to new Workbook By Checkbox [Excel Macro/VBA] - vba

So my main goal is to save sheets (depending on if they are selected by a checkbox) to a new workbook.
Here is my code:
Sub saveSheetWorkbook()
Dim exampleName As Variant
Dim exampleSavePath As String
Dim exampleSheet As Variant
exampleName = InputBox("Who will this be sent to?")
exampleSavePath = ActiveWorkbook.Path & "\" & exampleName
If Worksheets("Example Worksheet 1").Range("E29") = True Then
exampleSheet = "Example Worksheet 2"
End If
Sheets(Array("Example Worksheet 1"), exampleSheet).Copy
ActiveWorkbook.SaveAs Filename:=exampleSavePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
For example, I want to always save Example Worksheet 1, but only save Example Worksheet 2 if the checkbox is ticked. The cell E29 in Example Worksheet 1 is the linked cell for the checkbox.
So this macro works when the checkbox is ticked, but when the checkbox is unticked, I get an error.
I have set it up so that the sheet array either contains the name or nothing. but when containing nothing, that gives me the error.
Any help would be great.
Edit: I need this for 6 different checkboxes/sheets.

you have one parenthesis too much
then
Sub saveSheetWorkbook()
Dim exampleName As Variant
Dim exampleSavePath As String
Dim sheetsArray As Variant
exampleName = InputBox("Who will this be sent to?")
exampleSavePath = ActiveWorkbook.Path & "\" & exampleName
If Worksheets("Example Worksheet 1").Range("E29") Then
sheetsArray = Array("Example Worksheet 1", "Example Worksheet 2")
Else
sheetsArray = Array("Example Worksheet 1")
End If
Sheets(sheetsArray).Copy
ActiveWorkbook.SaveAs Filename:=exampleSavePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

You can use my example workbook to do this with form:
https://drive.google.com/open?id=0BzFv0oeets6ubHg2bk96SHotdkU
To create this by yourself, here is instructions:
Press ALT+F11 in order to open VBA window;
Create userform with name "Userform1"
Put listbox to form and change its name to "lstSheet"
Change its properties like shown below:
ListStyle: 1-fmListStyleOPtion;
MultiSelect: 1-fmMultiSelectMulti;
Userform code:
Option Explicit
Dim NewName As String
Dim ws As Worksheet
Dim NumSheets As Integer
Private Sub CommandButton1_Click()
Dim Count As Integer, i As Integer, j As Integer
Count = 0
For i = 0 To lstSheet.ListCount - 1
'check if the row is selected and add to count
If lstSheet.Selected(i) Then Count = Count + 1
Next i
For i = 0 To lstSheet.ListCount - 1
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Select True
Next i
For i = 0 To lstSheet.ListCount - 1
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Select False
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Activate
Next i
Unload Me
ActiveWindow.SelectedSheets.Copy
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Private Sub lstSheet_Click()
End Sub
Private Sub UserForm_Initialize()
Dim Sh As Variant
'for each loop the add visible sheets
For Each Sh In ActiveWorkbook.Sheets
'only visible sheetand exclude login sheet
If Sh.Visible = True Then
'add sheets to the listbox
Me.lstSheet.AddItem Sh.Name
End If
Next Sh
End Sub
Create Module and put this code there:
Sub showForm()
Userform1.Show
End Sub

Related

UserForm.Show within a prior Initial User form causes blank grey un-closeable workbook to open

Below is the excerpt of code where the "error(more like an unwanted occurrence)" happens. My code is running in a userform (not userform1) after a command button click. The initial form shows on workbook open. The second userform - UserForm1 in the code below - is a check box that I want to present to the user upon my IF condition. When the program gets there, it opens the UserForm1, but also opens a blank grey excel workbook. The workbook cannot be closed until I close the Userformm1 interface.
Note: the second msgbox does not display until AFTER I close the userform.
I tried searching for this problem, but couldn't find the issue in regards to UserForm stuff. Thanks in advance for any help.
Private Sub CommandButton1_Click()
Dim wbName As String, wb As Workbook, ws As Worksheet
Dim sht As Worksheet
Dim myValue As Variant
Dim counter As Integer
Dim EstNumAttempt As Boolean
EstNumAttemp = False
counter = 0
Dim ThisNum As String
Dim EstNum As String
Dim CopyFromBook As Workbook
Dim CopyToWbk As Workbook
Dim ShToCopy As Worksheet
Set CopyToWbk = ThisWorkbook
Application.ScreenUpdating = False
ThisUserPath = Application.ActiveWorkbook.Path
userDataPath = ThisUserPath & "\SBNBidDataSet01112018.xlsx"
Dim StartDate As String
Dim EndDate As String
StartDate = TextBox1.Value
EndDate = TextBox2.Value
EstNum = TextBox3.Value
Set wb = Workbooks.Open(userDataPath)
Set CopyFromWbk = wb
WSCount = wb.Worksheets.Count
If EstNum <> "" Then
EstNumAttempt = True
For X = 1 To WSCount
Set ws = wb.Sheets(X)
ThisNum = ws.Cells(2, 2)
If ThisNum = EstNum Then
counter = counter + 1
Set ShToCopy = CopyFromWbk.Worksheets(X)
ShToCopy.Copy After:=CopyToWbk.Sheets(CopyToWbk.Sheets.Count)
End If
Next X
If counter = 0 Then
MsgBox " That's probably not a valid EST# in SmartBidNet"
End If
End If
If IsDate(StartDate) = True And IsDate(EndDate) = True And EstNumAttempt = False Then
MsgBox "h"
wb.Application.Visible = False
UserForm1.Show
wb.Application.Visible = True
MsgBox "h"
'BLANK GREY SHEET HERE
For X = 100 To 101
Set ws = wb.Sheets(X)
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'future code
Next X
End If
wb.Close
Application.ScreenUpdating = False ' from before also!
End Sub
THIS IS NOT A SOLUTION, I tested a piece of your code and here is my feedback below.
I ran just this code in a workbook named testbook.xslm and I created a form (myForm that is just a grey layout, nothing on it):
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim anotherbook As Workbook
Dim anotherbook2 As Workbook
Dim anotherbook3 As Workbook
Set wb = Workbooks.Add
Set anotherbook = wb
Set anotherbook2 = wb
Set anotherbook3 = wb
MsgBox "h"
wb.Application.Visible = False
myForm.Show
wb.Application.Visible = True
MsgBox "h"
wb.Close
Application.ScreenUpdating = False ' from before also!
End Sub
From the user standpoint:
1) testbook opens
2) click the button -> book# opens on top of testbook
3) msgbox "h" pops up
4) x out of msgbox "h" -> Both workbooks disappear (testbook and book1)
5) my grey user form pops up (its empty)
6) x out of userform
7) testbook shows again on top of the new book created which is behind it
8) msgbox "h" #2 pops up
9) x out of msgbox
10) the book# behind testbook disappears
That's it. No grey box residue. How are you closing the userforms (the first one and the second one)? obviously I used the terminate with the x. I did not add any code. So how are you closing your form with no code?
Adding the same behavior occurs if I make multiple workbook references to wb.
So this code area is not your problem . . . .
Second test, still no problems, adding worksheets, running through the number of worksheets, copying them to the testbook.
Option Explicit
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim anotherbook As Workbook
Dim anotherbook2 As Workbook
Dim anotherbook3 As Workbook
Dim X As Double
Dim lastrow As Double
Dim thisNum As String
Set wb = Workbooks.Add
Set anotherbook = wb
Set anotherbook2 = wb
Set anotherbook3 = wb
Set wb2 = ThisWorkbook
wb.Worksheets.Add
wb.Worksheets.Add
wb.Worksheets.Add
wb.Worksheets.Add
wb.Worksheets.Add
wb.Worksheets.Add
myForm2.Show
MsgBox "h"
wb.Application.Visible = False
myForm.Show
wb.Application.Visible = True
MsgBox "h"
For X = 1 To wb.Worksheets.Count
Set ws = wb.Sheets(X)
thisNum = ws.Cells(2, 2)
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Copy After:=wb2.Worksheets(wb2.Worksheets.Count)
'future code
Next X
wb.Close
Application.ScreenUpdating = False ' from before also!
End Sub
Perhaps you have a lot of data being acted upon. Clear the clipboard after the paste? With:
Application.CutCopyMode = False
Digging - WWC

Copy Worksheets break links

I have the below 2 subs in VBA which perform 2 different but similar tasks. One allows you to selects sheets from a Workbook using a checkbox popup and then copies these sheets into a new blank Workbook. The other allows you to manually populate a list of names of the sheets you want to copy (i.e. setup a "batch" of sorts) on a sheet and then copy all the sheets across into a new blank Workbook in a similar fashion to the first.
The problem I am having is - with the first sub I am able to break links after copying into the new Workbook, but with the second sub I am not able to break links. I think it has to do with a number of defined names within the original Workbook, as if you "Move or Copy/Create a Copy" manually, you are able to break the links.
Is there any code I can add to the below (onto both subs if possible) which will automatically break all links in the new Workbook to the old one? Or at least, is it possible to amend the second sub so that it copies across in a similar fashion to the first one which will then allow me to break links manually?
Sub CopySelectedSheets()
'1. Declare variables
Dim I As Integer
Dim SheetCount As Integer
Dim TopPos As Integer
Dim lngCheckBoxes As Long, y As Long
Dim intTopPos As Integer, intSheetCount As Integer
Dim intHor As Integer
Dim intWidth As Integer
Dim intLBLeft As Integer, intLBTop As Integer, intLBHeight As Integer
Dim Printdlg As DialogSheet
Dim CurrentSheet As Worksheet, wsStartSheet As Worksheet
Dim CB As CheckBox
Dim firstSelected As Boolean
' Dim wb As Workbook
' Dim wbNew As Workbook
' Set wb = ThisWorkbook
' Workbooks.Add ' Open a new workbook
' Set wbNew = ActiveWorkbook
On Error Resume Next
Application.ScreenUpdating = False
'2. Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
'3. Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set wsStartSheet = ActiveSheet
Set Printdlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'4. Add the checkboxes
TopPos = 40
For I = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(I)
'Skip empty sheets and hidden sheets
If Application.CountA(CurrentSheet.Cells) <> 0 And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
Printdlg.CheckBoxes.Add 78, TopPos, 150, 16.5
Printdlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next I
'6. Move the OK and Cancel buttons
Printdlg.Buttons.Left = 240
'7. Set dialog height, width, and caption
With Printdlg.DialogFrame
.Height = Application.Max _
(68, Printdlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to generate"
End With
'Change tab order of OK and Cancel buttons
'so the 1st option button will have the focus
Printdlg.Buttons("Button 2").BringToFront
Printdlg.Buttons("Button 3").BringToFront
'9. Display the dialog box
CurrentSheet.Activate
wsStartSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If Printdlg.Show Then
For Each CB In Printdlg.CheckBoxes
If CB.Value = xlOn Then
If firstSelected Then
Worksheets(CB.Caption).Select Replace:=False
Else
Worksheets(CB.Caption).Select
firstSelected = True
End If
'For y = 1 To ActiveWorkbook.Worksheets.Count
'If WorksheetFunction.IsNumber _
'(InStr(1, "ActiveWorkbook.Sheets(y)", "Contents")) = True Then
'CB.y = xlOn
'End If
End If
Next
ActiveWindow.SelectedSheets.Copy
Else
MsgBox "No worksheets selected"
End If
End If
' Delete temporary dialog sheet (without a warning)
'' Application.DisplayAlerts = False
'' Printdlg.Delete
' Reactivate original sheet
'' CurrentSheet.Activate
'' wsStartSheet.Activate
'10.Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
Printdlg.Delete
'11.Reactivate original sheet
CurrentSheet.Activate
wsStartSheet.Activate
Application.DisplayAlerts = True
End Sub
Sub CopySpecificSheets()
'1. Declare Variables
Dim myArray() As String
Dim myRange As Range
Dim Cell As Range
Dim OldBook As String
Dim newBook As String
Dim a As Long
'2. Set Range of Lookup
Set myRange = Sheets("Report Batch").Range("A2:A40")
OldBook = ActiveWorkbook.Name
'3. Generate Array of Sheet Names removing Blanks
For Each Cell In myRange
If Not Cell = "" Then
a = a + 1
ReDim Preserve myArray(1 To a)
myArray(a) = Cell
End If
Next
'4. Copy Array of Sheets to new Workbook
For a = 1 To UBound(myArray)
If a = 1 Then
Sheets(myArray(a)).Copy
newBook = ActiveWorkbook.Name
Workbooks(OldBook).Activate
Else
Sheets(myArray(a)).Copy After:=Workbooks(newBook).Sheets(a - 1)
Workbooks(OldBook).Activate
End If
Next
End Sub
Try something like this:
Sub CopySpecificSheets()
'1. Declare Variables
Dim rngData As Range
Dim arrData As Variant
Dim arrSheets() As String
Dim lSheetCount As Long
Dim i As Long
Dim j As Long
'2. Initialize variables
Set rngData = Sheets("Report Batch").Range("A2:A40")
arrData = rngData.Value
lSheetCount = WorksheetFunction.CountA(rngData)
ReDim arrSheets(lSheetCount - 1)
'3. Fill the array with non blank sheet names
For i = LBound(arrData) To UBound(arrData)
If arrData(i, 1) <> vbNullString Then
arrSheets(j) = arrData(i, 1)
j = j + 1
End If
' early break if we have all the sheets
If j = lSheetCount Then
Exit For
End If
Next i
'4. Copy the sheets in one step
Sheets(arrSheets).Copy
End Sub
Thanks
This isn't tested, but I think if you add in a subroutine to your source workbook VBA code like this:
Sub BreakLinks(ByRef wb As Workbook)
Dim Links As Variant
Dim i As Long
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
And then call it after you copy the sheets to the new workbook
Call BreakLinks(newBook)
That should achieve the desired effect of severing those links. Just be sure the links are broken to any sort of Save or SaveAs operation so that the broken links are maintained.

Prompt user to select a worksheet

I have a Macro, that prompts a user to select an Excel file, like this:
Dim thisBook As Workbook, newBook As Workbook
Dim fd As FileDialog
Dim oFD As Variant
Dim fileName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.ButtonName = "Select"
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xls", 1
.Title = "Choose the Report"
.InitialView = msoFileDialogViewDetails
.Show
For Each oFD In .SelectedItems
fileName = oFD
Next oFD
On Error GoTo 0
End With
If fd.SelectedItems.Count = 0 Then
Exit Sub
End If
Set thisBook = ActiveWorkbook
Set newBook = Workbooks.Open(fileName)
This works fine, what I want to do now, and what I failed to find in the internet is the following:
I want to prompt the user to select a worksheet from the newbook, since the sheet name could not be the same in the future.
I came up with this, but I am not very happy with it, since it is rather inconvenient, to let the user type the sheet name:
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
Function q() As String
Dim shname As String
Do Until WorksheetExists(shname)
shname = InputBox("Enter sheet name")
If Not WorksheetExists(shname) Then MsgBox shname & " doesn't exist!", vbExclamation
Loop
q = shname
End Sub
Is there a way, to maybe let the user select the sheet name, from all the sheet names? (I am not using an Userform, the Macro starts, if the user clicks a Button)
Make a userform with a blank ListBox and use this code in the userform module
Private Sub UserForm_Initialize()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
ListBox1.AddItem sh.Name
Next sh
End Sub
Private Sub ListBox1_Click()
Sheets(ListBox1.Value).Activate
Unload Me
End Sub
Use an InputBox and have the user select any cell inside the desired/target sheet. Setting the type to 8 returns a Range. From this range, you can get the worksheet then its name.
Dim desiredSheetName as String
desiredSheetName = Application.InputBox("Select any cell inside the target sheet: ", "Prompt for selecting target sheet name", Type:=8).Worksheet.Name
Debug.Print desiredSheetName

Copy value from active sheet to new excel file

I have a work sheet named Final_Sheet, I want to create a button on that sheet and execute the following operation
Select Cell Range A1:D30 and pickup the values from cell only and create a new Excel file and paste the copied cell values into Sheet1 of created excel file. I am able to o this much, further I can't understand what to do can anybody please help me out?
Private Sub Button1_Click()
Dim rownum As Integer
Dim selection As Range
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
rownum = InputBox("Row No to Copy :", "OK")
selection = ActiveSheet.Range(Cells(1, 1), Cells(rownum, 10)).Select
selection.Copy
Flname = InputBox("Enter File Name :", "Creating New File...")
MsgBox ("Output File Created Successfully")
If Flname <> "" Then
Set NewWkbk = Workbooks.Add
ThisWorkbook.Sheets(1).Range("D1:D30").Copy Before:=NewWkbk.Sheets(1)
NewWkbk.Sheet(1).Select
Cells(1, 1).Activate
selection.PasteSpecial xlPasteValues
NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
ActiveWorkbook.Close
End If
End Sub
The code below should do as you've asked.
EDIT: Pastes values only
Private Sub Button1_Click()
'Dim Variables
Dim ws As Worksheet
Dim rng As Range
Dim wbNew As Workbook, wbCurrent As Workbook
Dim strFileName As String
'Assign object variables
Set wbCurrent = ActiveWorkbook
Set ws = wbCurrent.ActiveSheet
Set rng = ws.Range("A1:D30") 'Amend range if needed
'Get desired file path from user
strFileName = InputBox("Enter File Name: ", "Creating New File...")
If strFileName <> "" Then
'Create new Workbook and paste rng into it
Set wbNew = Workbooks.Add
rng.Copy
wbNew.Sheets(1).Range("A1:D30").PasteSpecial xlValues
'Save new workbook using desired filepath
wbNew.SaveAs wbCurrent.Path & "\" & strFileName
End If
End Sub
It wasn't clear to me from the question which workbook you wished to close with ActiveWorkbook.Close but you could easily add wbNew.Close or wbCurrent.Close below wbNew.SaveAs ... as required.

Opening workbooks via hyperlink and then using Hyperlink name as workbook reference

I'm trying to take the hyperlink workbook name and put it into my code.
Sub Workbook()
Dim vbaname as string
Dim WBMaster As Workbook, WBSource As Workbook
Dim WSMaster As Worksheet, WSSource As Worksheet
Range("b7").Hyperlinks(1).Follow
'returns the hyperlink text "Vba Source test"
VbaName = """" & Range("B7").Text & """"
Set WBSource = Workbooks(VbaName)
I get a subscript out of range bug. Is there another way to do this. I just want to be able to put the hyperlink text into that bracket.
If you Debug.Print your VbaName it actually holds the value of B7 but the active window ( the followed one from hyperlink ). If you want to get the name of the workbook from the hyperlink, youre working in, then use this code
Sub GetWorkbookName()
MsgBox "the name of the workbook in the hyperlink is: " & vbCrLf & _
getWorkbookName(Range("B7").Text)
End Sub
Private Function getWorkbookName(hyperLink As String) As String
Dim i&
For i = 1 To Len(hyperLink)
If StrComp(Left(Right(hyperLink, i), 1), "\", vbTextCompare) = 0 Then
getWorkbookName = Right(hyperLink, i - 1)
Exit For
End If
Next i
End Function
On the other hand, I think you are trying to open the workbook from the hyperlink and assign a reference to it. The way you go about it it's not the right approach. I think you may want to consider doing it this way:
Sub Workbook()
Dim wbFromHyperLink As String
Dim WBSource As Workbook
MsgBox "the name of the workbook in the hyperlink is: " & vbCrLf & _
getWorkbookName(Range("B7").Text)
wbFromHyperLink = getWorkbookName(Range("B7").Text)
'Range("b7").Hyperlinks(1).Follow
Set WBSource = Workbooks.Open(Range("B7").Text)
' do not forget to close and free the object
' WBSource.Saved = True
' WBSource.Close
' Set WBSource = Nothing
End Sub
Private Function getWorkbookName(hyperLink As String) As String
Dim i&
For i = 1 To Len(hyperLink)
If StrComp(Left(Right(hyperLink, i), 1), "\", vbTextCompare) = 0 Then
getWorkbookName = Right(hyperLink, i - 1)
Exit For
End If
Next i
End Function