How to generate barcodes in excel worksheet - excel

Just a short question, how to generate a barcode in excel worksheet? The barcode-text has been specified in a cell.
(Not intent to mass generate barcodes which otherwise can be done in MS Word.)

Select the range where barcode-text is written:
Then run the following script:
Sub INSERT_BARCODE()
Const BarcodeWidth As Integer = 156
Dim ws As Worksheet, WdApp
Set ws = ActiveSheet
Set WdApp = CreateObject("Word.Application")
With WdApp.Documents.Add
.PageSetup.RightMargin = .PageSetup.PageWidth - .PageSetup.LeftMargin - BarcodeWidth
.Fields.Add(Range:=.Range, Type:=-1, Text:="DISPLAYBARCODE " & CStr(Selection.Value) & " CODE39 \d \t", PreserveFormatting:=False).Copy
End With
ws.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
WdApp.Quit SaveChanges:=False
Set WdApp = Nothing
End Sub
Note:
Change the encoding rule as you like. This example uses CODE39 rule. Refer https://msdn.microsoft.com/en-us/library/hh745901(v=office.12).aspx for more details.
Adjust the BarcodeWidth interger to best fit the barcode.
BR~

This is massively over-specced for what you need, but you can pull the bits out of it as required.
Sub Call_Barcode_Service()
Dim strResource As String
Dim strSize As String
Dim iHgt As Integer
Dim iWth As Integer
Dim iGap As Integer
Dim PictureGrab As String
Dim lngLastRow As Long
strSize = UCase(InputBox("How Big?", "Small, Medium or Large?", "L"))
Select Case strSize
Case Is = "S"
iWth = 150
iHgt = 45
iGap = 3
Case Is = "M"
iWth = 150
iHgt = 60
iGap = 4
Case Is = "L"
iWth = 240
iHgt = 75
iGap = 5
Case Else
iWth = 250
iHgt = 75
iGap = 5
End Select
Set sel = Selection.SpecialCells(xlTextValues)
Set news = Worksheets.Add()
news.Name = "Barcodes"
Set op = news.Range("A1")
For Each acc In sel
strResource = acc.Value
PictureGrab = "http://www.barcodesinc.com/generator/image.php?code=" & strResource & "&style=197&type=C128B&width=" & iWth & "&height=" & iHgt & "&xres=1&font=1"
Set sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, op.Left, op.Top, iWth, iHgt)
With sh
.Name = strResource
.Line.Visible = False
.Fill.UserPicture PictureGrab
End With
Set op = op.Offset(iGap + 1, 0).Range("A1")
Next
Range("G1").Select
End Sub

I use word with Macro :
Sub Macro1()
'
' Macro1 Macro
' Test Barcode
'
Dim codei As String
Dim codej As String
For I = 1 To 1 '0
For J = 1 To 2 '0
codei = CStr(I)
While Len(codei) < 2
codei = "0" & codei
Wend
codej = CStr(J)
While Len(codej) < 4
codej = "0" & codej
Wend
codei = codei & codej
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="DisplayBarcode " & codei & " Code128 \t"
Selection.TypeParagraph
Selection.Fields.Update
Next J
Next I
End Sub

Related

Counter to increment variable value

I'm trying to name sheets based on the current date. I need a counter variable to name sheets so they're unique.
I made two attempts:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
counter = 0
Name01:
For counter = 1 To 100 Step 0
TxtError = ""
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
Next counter
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
Expected result:
And:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
TxtError = ""
shtname = Format(Now(), "dd mm yyyy")
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
If TxtError = "" Then GoTo NameOK
Name01:
For counter = 1 To 100 Step 1
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
Next counter
NameOK:
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
Expected result:
I will assign this code to a shape to create the sheets based on the current date.
I prefer result 2.
Copy Template
Sub CopyTemplate()
Const PROC_TITLE As String = "Copy Template"
Const TEMPLATE_WORKSHEET_NAME As String = "MODELO - NFS"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Const DATE_FORMAT As String = "dd mm yyyy"
Const DATE_NUMBER_DELIMITER As String = " - "
Const FIRST_NUMBER As Long = 2
Const FIRST_WORKSHEET_HAS_NUMBER As Boolean = False
Const INPUT_BOX_PROMPT As String = "Input number of worksheets to create."
Const INPUT_BOX_DEFAULT As String = "1"
Dim WorksheetsCount As String: WorksheetsCount _
= InputBox(INPUT_BOX_PROMPT, PROC_TITLE, INPUT_BOX_DEFAULT)
If Len(WorksheetsCount) = 0 Then Exit Sub
Dim DateName As String: DateName = Format(Date, DATE_FORMAT)
Dim NewName As String: NewName = DateName
Dim NewNumber As Long: NewNumber = FIRST_NUMBER
If FIRST_WORKSHEET_HAS_NUMBER Then
NewName = NewName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
End If
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsTemplate As Worksheet
Set wsTemplate = wb.Worksheets(TEMPLATE_WORKSHEET_NAME)
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsNew As Worksheet
Dim WorksheetNumber As Long
Application.ScreenUpdating = False
Do While WorksheetNumber < WorksheetsCount
On Error Resume Next
Set wsNew = wb.Worksheets(NewName)
On Error GoTo 0
If wsNew Is Nothing Then
wsTemplate.Copy Before:=wsBefore
wsBefore.Previous.Name = NewName
WorksheetNumber = WorksheetNumber + 1
Else
NewName = DateName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
Set wsNew = Nothing
End If
Loop
Application.ScreenUpdating = True
MsgBox WorksheetsCount & " worksheet" & IIf(WorksheetsCount = 1, "", "s") _
& " created.", vbInformation, PROC_TITLE
End Sub
If you overplay it...
Sub DeleteCreatedWorksheets()
Const PROC_TITLE As String = "Delete Created Worksheets"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsIndex As Long: wsIndex = wsBefore.Index - 1
If wsIndex > 0 Then
Application.DisplayAlerts = False
Dim n As Long
For n = wsIndex To 1 Step -1
wb.Worksheets(n).Delete
Next n
Application.DisplayAlerts = True
End If
MsgBox wsIndex & " created worksheet" _
& IIf(wsIndex = 1, "", "s") & " deleted.", _
vbInformation, PROC_TITLE
End Sub

excel vba not converting tamplate to word document

When I try to generate a word document, it gets stopped at the 80% progress bar and it shows the following error.
When I try to debug it, I see this
I'm getting error in now For i = 1 To .InlineShapes.Count
My code
Sub FillABookmark(strBM As String, strText As String)
Dim j As Long
With ActiveDocument
.Bookmarks(strBM).Range _
.InlineShapes _
.AddPicture FileName:=strText
j = ActiveDocument.InlineShapes.Count
.InlineShapes(j).Select
.Bookmarks.Add strBM, Range:=Selection.Range
End With
End Sub
Sub AddImage(strFile As String, addOrAfter As Boolean)
Dim oImage As Object
'Dim oDialog As Dialog
' Dim oRng As Object
' Set oDialog = Dialogs(wdDialogInsertPicture)
' With oDialog
' .Display
' If .Name <> "" Then
' strFile = .Name
' End If
'End With
'Selection.Move 6, -1 'moverse al principio del documento
'Selection.Find.Execute FindText:="[aud_sig_1]"
'If Selection.Find.Found = True Then
If (addOrAfter) Then
Set oImage = Selection.InlineShapes.AddPicture(strFile, False, True)
'With oRng
' .RelativeHorizontalPosition = _
' wdRelativeHorizontalPositionPage
' .RelativeVerticalPosition = _
' wdRelativeVerticalPositionPage
'.Left = CentimetersToPoints(0)
'.Top = CentimetersToPoints(4.5)
'End With
Else
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Set oImage = Selection.InlineShapes.AddPicture(strFile, False, True)
End If
With oImage
.LockAspectRatio = msoFalse
.Height = CentimetersToPoints(1.5)
.Width = CentimetersToPoints(2.1)
Set oRng = .ConvertToShape
End With
Set oDialog = Nothing
Set oImage = Nothing
Set oRng = Nothing
End Sub
Sub PicWithCaption(xPath, Optional ByVal imgType As String = "All")
Dim xFileDialog As FileDialog
Dim xFile As Variant
Dim doc As Document
'******Test
'Set doc = Application.ActiveDocument
'xPath = "C:\phototest\"
'doc.Bookmarks.Exists ("photos")
'doc.Bookmarks("photos").Select 'select the bookmark
'*****End test
Dim x, w, c
Dim oTbl As Word.Table, i As Long, j As Long, k As Long, StrTxt As String
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 3)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(9)
'Format the rows
Call FormatRows(oTbl, 1)
End With
If xPath <> "" Then
xFile = Dir(xPath & "\*.*")
i = 1
CaptionLabels.Add Name:="Picture"
Do While xFile <> ""
If (UCase(Right(xFile, 3)) = "PNG" Or _
UCase(Right(xFile, 3)) = "TIF" Or _
UCase(Right(xFile, 3)) = "JPG" Or _
UCase(Right(xFile, 3)) = "GIF" Or _
UCase(Right(xFile, 3)) = "BMP") And (imgType = "All" Or UCase(Left(xFile, 1) <> imgType)) Then
j = Int((i + 2) / 3) * 2 - 1
k = (i - 1) Mod 3 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
'Dim shape As InlineShape
' ActiveDocument.InlineShapes.AddPicture _
' FileName:=xPath & "\" & xFile, LinkToFile:=False, _
' SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
Set shape = ActiveDocument.InlineShapes.AddPicture(xPath & "\" & xFile, False, True, oTbl.Rows(j).Cells(k).Range)
oTbl.Rows(j).Cells(k).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
' With shape
' .LockAspectRatio = msoTrue
' If .Width > .Height Then
' .Height = InchesToPoints(1.75)
' Else
' .Width = InchesToPoints(1.75)
' End If
' End With
'shape.ScaleWidth = 50
'Get the Image name for the Caption
'StrTxt = Split(xPath & "\" & xFile, "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = xFile
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertParagraph
.InsertBefore StrTxt
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Font.Bold = True
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
End If
i = i + 1
xFile = Dir()
Loop
End If
'End If
End Sub
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(6)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
.Alignment = wdAlignRowCenter
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(1.2)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
.Alignment = wdAlignRowCenter
End With
End With
End Sub
Sub rezie()
Dim i As Long
With ThisDocument
For i = 1 To .InlineShapes.Count
Next i
End With
End Sub
Use the style enums to be on the safe side when on a non-english system:
.Range.Style = Word.wdStyleCaption (in case you are using early binding - what you are using)
In case of late binding: .Range.style = -35

VBA, data is not populating in new columns. Possible issue with Advanced Filter

We have added 5 new columns to three sheets in a workbook. The first sheet is like a staging table that then populates the other two. The problem is the new columns are not being populated with the data in the two final sheets. The data is visible in the intial sheet. I think it may be an issue with the Advanced Filter but im not sure. Any help would be appreciated.
Public Sub RunExtract()
Dim strExtractYear As String
Dim strExtractMonth As String
Dim strOutputFolder As String
Application.ScreenUpdating = False
'grab the control variable values
strExtractYear = Range("Extract_Year").Value
strExtractMonth = Range("Extract_Month").Value
strOutputFolder = Range("Output_Folder").Value
'pull the data
Application.StatusBar = "Pulling data..."
Call PullData(strExtractYear, strExtractMonth)
'filter and output the results
Application.StatusBar = "Extracting 310 summary data..."
Range("SummaryFilter.Criteria").Cells(2, 2).Formula = "=""=310"""
Call FilterData(Range("SalesExtract.Table"), Range("SummaryFilter.Criteria"), Range("SummaryFilter.Header"), "SummaryFilter.Table")
Call OutputResults("SUMMARY", "310", strOutputFolder)
Application.StatusBar = "Extracting 430 summary data..."
Range("SummaryFilter.Criteria").Cells(2, 2).Formula = "=""=430"""
Call FilterData(Range("SalesExtract.Table"), Range("SummaryFilter.Criteria"), Range("SummaryFilter.Header"), "SummaryFilter.Table")
Call OutputResults("SUMMARY", "430", strOutputFolder)
Application.StatusBar = "Extracting 310 detail data..."
Range("DetailFilter.Criteria").Cells(2, 2).Formula = "=""=310"""
Call FilterData(Range("SalesExtract.Table"), Range("DetailFilter.Criteria"), Range("DetailFilter.Header"), "DetailFilter.Table")
Call OutputResults("DETAIL", "310", strOutputFolder)
Application.StatusBar = "Extracting 430 detail data..."
Range("DetailFilter.Criteria").Cells(2, 2).Formula = "=""=430"""
Call FilterData(Range("SalesExtract.Table"), Range("DetailFilter.Criteria"), Range("DetailFilter.Header"), "DetailFilter.Table")
Call OutputResults("DETAIL", "430", strOutputFolder)
Call CleanUpThisWorkbook
Application.StatusBar = "Done"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Public Sub PullData(ExtractYear As String, ExtractMonth As String)
Dim conn As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim strStartDate As String
Dim strStartDateTime As String
Dim strEndDateTime As String
Dim strYear As String
Dim strMonth As String
Dim strLastDay As String
'clear the existing range
Range("SalesExtract.Table").CurrentRegion.Offset(1).EntireRow.Delete
'figure out the start and end datetimes
strYear = ExtractYear
strMonth = Right("0" & ExtractMonth, 2)
strStartDate = "{year}-{month}-{day}"
strStartDate = Replace(strStartDate, "{year}", strYear)
strStartDate = Replace(strStartDate, "{month}", strMonth)
strStartDate = Replace(strStartDate, "{day}", "01")
strStartDateTime = strStartDate & " 00:00:00"
strLastDay = CStr(Day(DateSerial(Year(strStartDate), Month(strStartDate) + 1, 0)))
strEndDateTime = "{year}-{month}-{day} 23:59:59"
strEndDateTime = Replace(strEndDateTime, "{year}", strYear)
strEndDateTime = Replace(strEndDateTime, "{month}", strMonth)
strEndDateTime = Replace(strEndDateTime, "{day}", strLastDay)
Private Sub OutputResults(Level As String, Company As String, Directory As String)
Dim wb As Workbook
Set wb = Workbooks.Add
Dim strSheet As String
If Level = "SUMMARY" Then
strSheet = "SummaryFilter"
ElseIf Level = "DETAIL" Then
strSheet = "DetailFilter"
Else
'raise error
End If
Call ThisWorkbook.Worksheets(strSheet).Range(strSheet & ".Table").Copy
Call wb.Worksheets(1).Range("A1").PasteSpecial(xlPasteValues)
Call ThisWorkbook.Worksheets(strSheet).Range(strSheet & ".ReplacementHeader").Copy
Call wb.Worksheets(1).Range("A1").PasteSpecial(xlPasteValues)
wb.Worksheets(1).Name = Level & " " & Company
Application.DisplayAlerts = False
Call wb.SaveAs(Directory & "\Sales Extract - " & Level & " " & Company & ".xlsx")
Application.DisplayAlerts = True
Call wb.Close
Set wb = Nothing
End Sub
Private Sub FilterData(FilterRng As Range, CriteriaRng As Range, CopyToRng As Range, NameMe As String, Optional FilterUnique As Boolean)
With CopyToRng
If WorksheetFunction.CountA(.Offset(1, 0).Resize(1, .Columns.Count)) <> 0 Then
CopyToRng.CurrentRegion.Offset(1, 0).ClearContents
End If
End With
FilterRng.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=CriteriaRng, _
CopyToRange:=CopyToRng, _
Unique:=FilterUnique
CopyToRng.CurrentRegion.Name = NameMe
End Sub
Private Sub CleanUpThisWorkbook()
Range("SalesExtract.Table").Offset(1).EntireRow.Delete
Range("SummaryFilter.Table").Offset(1).EntireRow.Delete
Range("DetailFilter.Table").Offset(1).EntireRow.Delete
End Sub

Excel isn't closing

I am running the following working Macro on word visual basic. Each time I run it, the macro successfully generates the report how I want it to; but then I look in the task manager and I see that an instance of excel is still running. I run the debugger over the code, the debugger goes through the final line:
oExcel.quit
and yet it still doesn't terminate the application!
Sub WriteExtension()
'
' WriteExtension Macro
'
'
copyFile
Dim nWord As New Document
word.Application.ScreenUpdating = False
Set nWord = Documents.Open("c:\output\report\here\report", Visible:=False)
'initialize excel variables
Dim oExcel As Excel.Application
Dim oWorkbook As workbook
Dim oWorksheet As worksheet
'initialize excel object
Set oExcel = New Excel.Application
oExcel.ScreenUpdating = False
Set oWorkbook = oExcel.Workbooks.Open("c:\spreadsheet\here\spreadsheet.xlsx")
Set oWorksheet = oWorkbook.Worksheets(Sheets("Extensions").Index)
'setup loop variables
Dim tempString As String
Dim delim As String
Dim i As Long
Dim bkMark As Bookmark
Dim questions(13) As String
questions(0) = 13
questions(1) = 15
questions(2) = 17
questions(3) = 19
questions(4) = 29
questions(5) = 31
questions(6) = 33
questions(7) = 36
questions(8) = 38
questions(9) = 40
questions(10) = 42
questions(11) = 46
questions(12) = 48
delim = "#"
tempString = delim & Join(questions, delim)
Dim bmrange As Range
For i = 1 To 78
If (InStr(1, tempString, delim & i & delim, vbTextCompare)) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If (Cells(4, i + 6) = 1) Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
ElseIf (InStr(1, tempString, delim & (i - 1) & delim, vbTextCompare)) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If (Cells(4, i + 6) = 1) Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
Else
nWord.Bookmarks.Item("BM" & i).Range.InsertAfter (Cells(4, i + 6))
End If
Next i
Dim filePath As String
Dim fileName As String
Dim newName As String
' save the file as a PDF and close the PDF
filePath = "c:\output\report\here\report"
fileName = Cells(4, 13) & Cells(4, 12) & Cells(4, 79) & ".pdf"
newName = filePath & fileName
nWord.SaveAs2 fileName:=newName, FileFormat:=wdFormatPDF
' Close things
nWord.Close False
oWorkbook.Close False
oExcel.Quit
End Sub
I suspect that your issue is related to your unqualified Sheets and Cells references.
Set oWorksheet = oWorkbook.Worksheets(Sheets("Extensions").Index) should probably just be Set oWorksheet = oWorkbook.Worksheets("Extensions") (no need to get the index of a sheet by using its name just to get a reference to the sheet, when you can just index it by its name) and Cells(4, i + 6) should probably be oWorksheet.Cells(4, i + 6).
I could replicate your issue before I made those changes (although sometimes the code would just crash), but once I fixed them Excel correctly closed at the End Sub. (It didn't disappear after the oExcel.Quit because oExcel wasn't Nothing yet.)
Sub WriteExtension()
'
' WriteExtension Macro
'
'
copyFile
Dim nWord As New Document
word.Application.ScreenUpdating = False
Set nWord = Documents.Open("c:\output\report\here\report", Visible:=False)
'initialize excel variables
Dim oExcel As Excel.Application
Dim oWorkbook As workbook
Dim oWorksheet As worksheet
'initialize excel object
Set oExcel = New Excel.Application
oExcel.ScreenUpdating = False
Set oWorkbook = oExcel.Workbooks.Open("c:\spreadsheet\here\spreadsheet.xlsx")
Set oWorksheet = oWorkbook.Worksheets("Extensions")
'setup loop variables
Dim tempString As String
Dim delim As String
Dim i As Long
Dim bkMark As Bookmark
Dim questions(13) As String
questions(0) = 13
questions(1) = 15
questions(2) = 17
questions(3) = 19
questions(4) = 29
questions(5) = 31
questions(6) = 33
questions(7) = 36
questions(8) = 38
questions(9) = 40
questions(10) = 42
questions(11) = 46
questions(12) = 48
delim = "#"
tempString = delim & Join(questions, delim)
Dim bmrange As Range
For i = 1 To 78
If (InStr(1, tempString, delim & i & delim, vbTextCompare)) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If oWorksheet.Cells(4, i + 6) = 1 Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
ElseIf InStr(1, tempString, delim & (i - 1) & delim, vbTextCompare) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If oWorksheet.Cells(4, i + 6) = 1 Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
Else
nWord.Bookmarks.Item("BM" & i).Range.InsertAfter (oWorksheet.Cells(4, i + 6))
End If
Next i
Dim filePath As String
Dim fileName As String
Dim newName As String
' save the file as a PDF and close the PDF
filePath = "c:\output\report\here\report"
fileName = oWorksheet.Cells(4, 13) & oWorksheet.Cells(4, 12) & oWorksheet.Cells(4, 79) & ".pdf"
newName = filePath & fileName
nWord.SaveAs2 fileName:=newName, FileFormat:=wdFormatPDF
' Close things
nWord.Close False
oWorkbook.Close False
oExcel.Quit
'Optional: Set Excel objects to Nothing so that Excel closes now instead of at End Sub
Set oWorkbook = Nothing
Set oExcel = Nothing
End Sub

"object invoked has disconnected from its clients" Excel 2016

I have seen this asked multiple times but none of the solutions offered have solved my issue- I continue to get this error even though I have used the same code in multiple other applications with no errors. I have included the code below and hope that someone can spot the issue that I am just failing to see!
Sub CreateJobsGraphsPrincipalCategory()
'Initial variables
Dim wbnew As Workbook
Dim wsnew As Worksheet
Dim Datasheet As Worksheet
'Dataset variables
Dim BeneficiaryList(0 To 10000), PrincipalList(0 To 10000), CheckRange As String
Dim NumberRows, RowNumber As Long
Dim Isduplicate, intPrincipal, intStatus, intLineItem As Integer
Dim PrincipalColumn, StatusColumn, LineItemColumn As String
Dim PrincipalRange, StatusRange, LineItemRange As String
Dim PrincipalNumber, BeneficiaryNumber As Integer
'New PivotChart variables
Dim objPivotcache As PivotCache
Dim objPivotTable As PivotTable
Dim bcount As Integer
Dim ProsperatorArray(1 To 25) As String
Dim BusinessNameColumn, BeneficiaryName, BeneficiaryNameFind As String
Dim objPivot As PivotTable, objPivotRange As Range, objChart As Chart
Dim LastColumnNumber As Double
'Setup workbooks
Dim CurrentWorkbook As Workbook
Dim SaveToWorkbook As Workbook
'Stop screen updating and calculating furing processing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Select overall datasheet
Worksheets("DataforPrincipals").Activate
Set Datasheet = ActiveSheet
'Find last column. Start from column 30 as it will not be less than this
LastColumnNumber = 30
LastColumnValue = Datasheet.Cells(1, LastColumnNumber)
While LastColumnValue <> ""
LastColumnNumber = LastColumnNumber + 1
LastColumnValue = Datasheet.Cells(1, LastColumnNumber)
Wend
LastColumnNumber = LastColumnNumber - 1
'LastColumnValue = Datasheet.Cells(1, LastColumnNumber)
LastColumnValue = Getcolumn(LastColumnNumber)
'get last row
LastRowNumber = 1
LastRowRange = "A" & LastRowNumber
LastRowValue = Datasheet.Cells(LastRowNumber, 1)
While LastRowValue <> ""
LastRowNumber = LastRowNumber + 1
LastRowRange = "A" & LastRowNumber
LastRowValue = Datasheet.Cells(LastRowNumber, 1)
Wend
LastRowNumber = LastRowNumber - 1
PivotRange = "A" & "1" & ":" & LastColumnValue & LastRowNumber
'Creating Pivot cache
Set objPivotcache = ActiveWorkbook.PivotCaches.Create(xlDatabase, "'DataforPrincipals'!" & PivotRange)
'Create Arrays for Beneficiaries and Principals
'Get Columns for filtering and checking
PrincipalColumn = FindDataColumnHeading("Principal")
' StatusColumn = FindDataColumnHeading("Status")
LineItemColumn = FindDataColumnHeading("Line Item")
BusinessNameColumn = FindDataColumnHeading("Business Name")
RowNumber = 2
NumberRows = 0
CheckRange = BusinessNameColumn & RowNumber
PrincipalNumber = 1
BeneficiaryNumber = 1
While Datasheet.Range(CheckRange) <> ""
NumberRows = NumberRows + 1
PrincipalRange = PrincipalColumn & RowNumber
' StatusRange = StatusColumn & RowNumber
LineItemRange = LineItemColumn & RowNumber
' If Datasheet.Range(StatusRange) = "Active" Then
If Datasheet.Range(LineItemRange) = "Turnover" Then
BeneficiaryList(BeneficiaryNumber) = Datasheet.Range(CheckRange)
BeneficiaryNumber = BeneficiaryNumber + 1
'Check if principal is in the dataset yet
If RowNumber = 2 Then
PrincipalList(PrincipalNumber) = UCase(Trim(Datasheet.Range(PrincipalRange)))
Else
PrincipalNumber = PrincipalNumber + 1
Isduplicate = 0
For i = 1 To PrincipalNumber
If PrincipalList(i) = UCase(Trim(Datasheet.Range(PrincipalRange))) Then
Isduplicate = 1
End If
Next i
If Isduplicate = 0 Then
PrincipalList(PrincipalNumber) = UCase(Trim(Datasheet.Range(PrincipalRange)))
Else
PrincipalNumber = PrincipalNumber - 1
End If
End If
End If
' End If
RowNumber = RowNumber + 1
CheckRange = BusinessNameColumn & RowNumber
Wend
Set CurrentWorkbook = Application.ActiveWorkbook
' Set wbnew = Workbooks.Add
'wbnew = ActiveWorkbook.Name
CurrentWorkbook.Activate
For i = 1 To PrincipalNumber
PrincipalNameFind = PrincipalList(i)
If PrincipalList(i) <> PrincipalList(i - 1) Then
If InStr(1, PrincipalList(i), "(") > 0 Then
PrincipalName = Left(PrincipalList(i), 25) & 0
Else
PrincipalName = Left(PrincipalList(i), 25)
End If
'Adding new worksheet
Worksheets("DataforPrincipals").Activate
Set wsnew = Worksheets.Add
wsnew.Name = PrincipalName & "JC"
Worksheets(PrincipalName & "JC").Activate
'Creating Pivot table
Set objPivotTable = objPivotcache.CreatePivotTable(wsnew.Range("A1"))
'set Beneficiary row field
'Setting Fields
With objPivotTable
With .PivotFields("Principal")
.Orientation = xlPageField
.CurrentPage = "ALL"
.ClearAllFilters
.CurrentPage = PrincipalNameFind
End With
'set data fields (PI TO, TO)
With .PivotFields("Category")
.Orientation = xlRowField
End With
.AddDataField .PivotFields("PI Total Staff"), "PI Jobs", xlSum
.AddDataField .PivotFields("Current Total Staff"), "Current Jobs", xlSum
.AddDataField .PivotFields("Job Growth"), "Job Growth ", xlSum
With .PivotFields("PI Jobs")
.NumberFormat = "#"
End With
With .PivotFields("Current Jobs")
.NumberFormat = "#"
End With
With .PivotFields("Job Growth ")
.NumberFormat = "#%"
End With
End With
' Access the new PivotTable from the sheet's PivotTables collection.
Set objPivot = ActiveSheet.PivotTables(1)
' Add a new chart sheet.
Set objChart = Charts.Add
' Create a Range object that contains
' all of the PivotTable data, except the page fields.
Set objPivotRange = objPivot.TableRange1
' Specify the PivotTable data as the chart's source data.
With objChart
.ShowAllFieldButtons = False
.SetSourceData objPivotRange
.ChartType = xlColumnClustered
.ApplyLayout (5)
With .ChartTitle
.Text = " Employment Growth performance per Category"
End With
.SeriesCollection(1).HasDataLabels = False
.SeriesCollection(2).HasDataLabels = False
.SeriesCollection(3).HasDataLabels = False
.Axes(xlCategory).HasTitle = False
.DataTable.Select
End With
If InStr(1, PrincipalList(i), "(") > 0 Then
PrincipalName = Left(PrincipalList(i), 25) & 0
Else
PrincipalName = Left(PrincipalList(i), 25)
End If
ActiveSheet.Name = PrincipalName & " JCG"
If Sheetslist = "" Then
Sheetslist = PrincipalName & " JCG"
Else
Sheetslist = Sheetslist & ", " & PrincipalName & " JOBS"
End If
End If
Next i
'Copy to new file
Set CurrentWorkbook = Application.ActiveWorkbook
DirectoryName = Sheets("Run Automated").Range("B1")
For i = 1 To PrincipalNumber
If PrincipalList(i) <> PrincipalList(i - 1) Then
With Worksheets("Run Automated")
NameFileInitial = .Range("B2") & " " & PrincipalList(i) & ".xlsm"
End With
If InStr(1, PrincipalList(i), "(") > 0 Then
PrincipalName = Left(PrincipalList(i), 25) & 0
Else
PrincipalName = Left(PrincipalList(i), 25)
End If
'Set sheets to save
sheet1save = PrincipalName & " TC"
sheet2save = PrincipalName & " TOC"
sheet7save = PrincipalName & "JC"
sheet8save = PrincipalName & " JCG"
Set CurrentWorkbook = Application.ActiveWorkbook
Namefile = DirectoryName & "\" & NameFileInitial
Workbooks.Open Namefile
Set SaveToWorkbook = Application.ActiveWorkbook
Application.DisplayAlerts = False
CurrentWorkbook.Sheets(Array(sheet1save, sheet2save, sheet7save, sheet8save)).Move Before:=SaveToWorkbook.Sheets(1)
ActiveWorkbook.Close (True)
Application.DisplayAlerts = True
CurrentWorkbook.Activate
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Resources