Dear all,
I have struggled with a code to copy sheets from excell to a word file. The copy sheets code works properly as stand-alone code. When I try to combine it with the "selected" checkboxes in userform part I cannot find the problem in the code/program.
I hope somebody can assist
I have added a copy of my userform to this thread.
By use of this code when I click the "copy sheets to word file":
'VBA, Print The Sheets That Were Selected in the UserForm into 1 PDF
Private Sub CommandButton3_Click()
'Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr 'OUTCOMMENTED BY MARIO
'Public Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
'Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Dim WidthAvail As Double, ARR() As Variant, ws As Worksheet
Dim WdDoc As Object, WdApp As Object, Cnt As Integer, Cnter As Integer
Dim Prng1 As Range, Prng2 As Range, Prng3 As Range
Dim WS_Count As Integer
Dim I As Integer
Dim names As String
Dim checkbox As Control
Dim fileSave As Variant
Dim msg As Integer
Dim actvsheet As String
Application.ScreenUpdating = False
'Get the active sheet name to return to the current sheet after the task is done.
actvsheet = ThisWorkbook.ActiveSheet.Name
'Let's the user choose the path to save the file
Set fileSave = Application.FileDialog(msoFileDialogSaveAs)
'The UserForm has checkboxes. Each checkbox has a caption after a sheetname. This for loop checks which sheets are selected by the user to be printed.
For Each checkbox In Me.Controls
If TypeName(checkbox) = "CheckBox" Then
If checkbox.Value = True Then
names = names & checkbox.Caption & ","
End If
End If
Next
'Makes sure that if no boxes were selected the process stops.
If Len(names) > 1 Then
names = Left(names, Len(names) - 1)
Else:
Application.ScreenUpdating = True
Exit Sub
End If
'Creates an array of the selected sheets and selects the corresponding sheets.
Sheets(Split(names, 9, 10)).Select
' Set WS_Count equal to the number of worksheets in the active workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
'For I = 1 To WS_Count
'set page print ranges
With Sheets("7")
Set Prng1 = .Range(.Cells(1, "A"), .Cells(58, "O"))
Set Prng2 = .Range(.Cells(1, "A"), .Cells(1, "B")) '
Set Prng3 = .Range(.Cells(1, "A"), .Cells(1, "B")) '
End With
'make array of print ranges
ARR = Array(Prng1, Prng2, Prng3)
'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If
On Error GoTo erfix
'open doc **********change file path to suit
Set WdDoc = WdApp.Documents.Open(Filename:="C:\Users\XXXXX\XXXXX\XXXXXX\test.docx")
With WdApp.ActiveDocument
.Range(0, .Characters.Count).Delete
End With
'determine width
With WdApp.ActiveDocument.PageSetup
WidthAvail = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
'loop print ranges
For Cnter = LBound(ARR) To UBound(ARR)
Cnt = Cnt + 1
ARR(Cnter).Copy
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9 '4
'size range pic to sheet
'With WdDoc.Shapes(Cnt)
'.LockAspectRatio = msoFalse
'.Width = WidthAvail
'End With
'size range pic to sheet
With WdDoc.Shapes(Cnt)
.LockAspectRatio = msoFalse
.Width = WidthAvail
.ScaleHeight 0.95, False
End With
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
'paste to seperate page
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
Next Cnter
'MsgBox ActiveWorkbook.Worksheets(I).Name
'Next I
' End Sub
'clean up
WdApp.ActiveDocument.Close SaveChanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Exit Sub
erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close SaveChanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
End Sub
'Prompts user with an are you sure message. Shows the name of the selected sheets.
' msg = MsgBox("These documents will be printed as PDF " + Chr(10) + Replace(names, ",", Chr(10)), vbQuestion + vbOKCancel)
'If User choses ok proceeds with the printing.
' If msg = vbOK Then
'Let's the user choose a directory to save the file
' With fileSave
' .InitialFileName = "Desktop\*.pdf"
'FilterIndex for a PDF file is 26 (You can count which row is a file type at when you Save As to get the desired file type's Index number.
' .FilterIndex = 26
'If user choses OK on the Save as screen.
' If .Show = -1 Then
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1), _
Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' Sheets(actvsheet).Select
'If User choses cancel on the Save as screen.
' Else
'Returns to the sheet that was active when the code was started (Makes sure multiple sheets are not selected when the procedure is over.)
' Sheets(actvsheet).Select
'Application.ScreenUpdating = True
' Exit Sub
' End If
' End With
'If the user chooses Cancel to the msgBox, cancels the printing.
' Else
' Sheets(actvsheet).Select
'Application.ScreenUpdating = True
' Exit Sub
' End If
'Application.ScreenUpdating = True
'Unload Me
'End Sub
When I run the code I can see that the selected sheets are selected in the Lokal Var. column.
I get the error "subscript out of range" on this piece of code
My first impression was that the error was caused because the are more checkboxes than sheets. So I reduced the number of checkboxes, which didn't solve the issue.
I hope Somebody can assist.
Thanks in advance
I have struggled with a code to copy sheets from excell to a word file. The copy sheets code works properly as stand-alone code. When I try to combine it with the "selected" checkboxes in userform part I cannot find the problem in the code/program.
I hope somebody can assist
I have added a copy of my userform to this thread.
By use of this code when I click the "copy sheets to word file":
'VBA, Print The Sheets That Were Selected in the UserForm into 1 PDF
Private Sub CommandButton3_Click()
'Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr 'OUTCOMMENTED BY MARIO
'Public Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
'Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Dim WidthAvail As Double, ARR() As Variant, ws As Worksheet
Dim WdDoc As Object, WdApp As Object, Cnt As Integer, Cnter As Integer
Dim Prng1 As Range, Prng2 As Range, Prng3 As Range
Dim WS_Count As Integer
Dim I As Integer
Dim names As String
Dim checkbox As Control
Dim fileSave As Variant
Dim msg As Integer
Dim actvsheet As String
Application.ScreenUpdating = False
'Get the active sheet name to return to the current sheet after the task is done.
actvsheet = ThisWorkbook.ActiveSheet.Name
'Let's the user choose the path to save the file
Set fileSave = Application.FileDialog(msoFileDialogSaveAs)
'The UserForm has checkboxes. Each checkbox has a caption after a sheetname. This for loop checks which sheets are selected by the user to be printed.
For Each checkbox In Me.Controls
If TypeName(checkbox) = "CheckBox" Then
If checkbox.Value = True Then
names = names & checkbox.Caption & ","
End If
End If
Next
'Makes sure that if no boxes were selected the process stops.
If Len(names) > 1 Then
names = Left(names, Len(names) - 1)
Else:
Application.ScreenUpdating = True
Exit Sub
End If
'Creates an array of the selected sheets and selects the corresponding sheets.
Sheets(Split(names, 9, 10)).Select
' Set WS_Count equal to the number of worksheets in the active workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
'For I = 1 To WS_Count
'set page print ranges
With Sheets("7")
Set Prng1 = .Range(.Cells(1, "A"), .Cells(58, "O"))
Set Prng2 = .Range(.Cells(1, "A"), .Cells(1, "B")) '
Set Prng3 = .Range(.Cells(1, "A"), .Cells(1, "B")) '
End With
'make array of print ranges
ARR = Array(Prng1, Prng2, Prng3)
'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If
On Error GoTo erfix
'open doc **********change file path to suit
Set WdDoc = WdApp.Documents.Open(Filename:="C:\Users\XXXXX\XXXXX\XXXXXX\test.docx")
With WdApp.ActiveDocument
.Range(0, .Characters.Count).Delete
End With
'determine width
With WdApp.ActiveDocument.PageSetup
WidthAvail = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
'loop print ranges
For Cnter = LBound(ARR) To UBound(ARR)
Cnt = Cnt + 1
ARR(Cnter).Copy
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9 '4
'size range pic to sheet
'With WdDoc.Shapes(Cnt)
'.LockAspectRatio = msoFalse
'.Width = WidthAvail
'End With
'size range pic to sheet
With WdDoc.Shapes(Cnt)
.LockAspectRatio = msoFalse
.Width = WidthAvail
.ScaleHeight 0.95, False
End With
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
'paste to seperate page
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
Next Cnter
'MsgBox ActiveWorkbook.Worksheets(I).Name
'Next I
' End Sub
'clean up
WdApp.ActiveDocument.Close SaveChanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Exit Sub
erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close SaveChanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
End Sub
'Prompts user with an are you sure message. Shows the name of the selected sheets.
' msg = MsgBox("These documents will be printed as PDF " + Chr(10) + Replace(names, ",", Chr(10)), vbQuestion + vbOKCancel)
'If User choses ok proceeds with the printing.
' If msg = vbOK Then
'Let's the user choose a directory to save the file
' With fileSave
' .InitialFileName = "Desktop\*.pdf"
'FilterIndex for a PDF file is 26 (You can count which row is a file type at when you Save As to get the desired file type's Index number.
' .FilterIndex = 26
'If user choses OK on the Save as screen.
' If .Show = -1 Then
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1), _
Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' Sheets(actvsheet).Select
'If User choses cancel on the Save as screen.
' Else
'Returns to the sheet that was active when the code was started (Makes sure multiple sheets are not selected when the procedure is over.)
' Sheets(actvsheet).Select
'Application.ScreenUpdating = True
' Exit Sub
' End If
' End With
'If the user chooses Cancel to the msgBox, cancels the printing.
' Else
' Sheets(actvsheet).Select
'Application.ScreenUpdating = True
' Exit Sub
' End If
'Application.ScreenUpdating = True
'Unload Me
'End Sub
When I run the code I can see that the selected sheets are selected in the Lokal Var. column.
I get the error "subscript out of range" on this piece of code
My first impression was that the error was caused because the are more checkboxes than sheets. So I reduced the number of checkboxes, which didn't solve the issue.
I hope Somebody can assist.
Thanks in advance
