"object invoked has disconnected from its clients" Excel 2016 - excel

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

Related

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

Visual Basic For Applications " subscript out of range" error

" I am getting a subscript out of range error after adding two new elements to an array. I remove the elements and re-run the code and it works. I need to know where to change the range so that it accommodates the array elements. This is the edited code: products = Array("BALANCER", "SKIN LIGHTENER", "FIRM AND FADE 6%", "FIRM AND FADE 8%")
After adding the two additional elements the error is thrown.
Research is showing that the array is the issue however after making adjustments the error message is still being thrown. "
"Here is the original code:"
Public Sub Dermesse_Dashboard(SD As Date, ED As Date)
Dim cn As ADODB.Connection
Dim rs As ADODB.RecordSet
Dim com As ADODB.Command
Dim ConnectionString As String, StoredProcName As String
Dim StartDate As ADODB.Parameter, EndDate As ADODB.Parameter, Product As ADODB.Parameter
Dim excelrange As String
Dim DateRange As String
Dim RCount As Integer
Dim products As Variant
products = Array("BALANCER", "SKIN LIGHTENER")
Set cn = New ADODB.Connection
Set rs = New ADODB.RecordSet
Set com = New ADODB.Command
Workbooks.Open ("\\apfssvr01\Arrow_RX\Reports\Templates\Dermesse_Dashboard(Template).xlsx")
ConnectionString = "Provider=sqloledb;Data Source=ARWSQL01;initial catalog=futurefill;User Id=endicia;Pwd=endicia;trusted_connection=yes;"
On Error GoTo CloseConnection
Application.ScreenUpdating = False
cn.Open ConnectionString
cn.CursorLocation = adUseClient
StoredProcName = "Dermesse_Shipped_by_Product"
With com
.ActiveConnection = cn
.CommandType = adCmdStoredProc
.CommandText = StoredProcName
End With
Set StartDate = com.CreateParameter("#StartDate", adDBTimeStamp, adParamInput, , SD)
com.Parameters.Append StartDate
Set EndDate = com.CreateParameter("#Enddate", adDBTimeStamp, adParamInput, , ED)
com.Parameters.Append EndDate
ActiveWorkbook.Sheets(2).Select
'loop through each item in products.
For Each i In products
'remove the product parameter if it exists so we can set it to the next product
If Product Is Nothing = False Then
com.Parameters.Delete (2)
End If
Set Product = com.CreateParameter("#Product", adVarChar, adParamInput, 200, i)
com.Parameters.Append Product
Set rs = com.Execute
'add rows to the excel table if the record set if 2 or greater.
'if we dont any tables below the first could be over written
If rs.RecordCount >= 2 Then
For j = 0 To rs.RecordCount - 3
ActiveSheet.ListObjects("Ship " & i).ListRows.Add (2)
Next
End If
ActiveSheet.ListObjects("Ship " & i).DataBodyRange.Select
Selection.CopyFromRecordset rs
rs.Close
Next
ActiveWorkbook.Sheets(6).Select
StoredProcName = "Dermesse_Shipped_wOrder"
With com
.ActiveConnection = cn
.CommandType = adCmdStoredProc
.CommandText = StoredProcName
End With
If Product Is Nothing = False Then
com.Parameters.Delete (2)
End If
Set Product = com.CreateParameter("#Product", adVarChar, adParamInput, 200, "Dermesse")
com.Parameters.Append Product
Set rs = com.Execute
RCount = rs.RecordCount
With ActiveSheet.ListObjects("Invoice DERMESSE")
If rs.RecordCount >= 2 Then
For j = 0 To rs.RecordCount - 3
.ListRows.Add (2)
Next
End If
.DataBodyRange.Select
Selection.CopyFromRecordset rs
.ListColumns(12).Range.Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(#_)"
End With
rs.Close
cn.Close
'set a data fee value for each record. look at the order number of a specific line. if the line above or below are the same
'the data fee is 7.5 else is 10
r = 9
For i = 0 To RCount - 1
If ActiveSheet.Range("C" & r + i).Value = ActiveSheet.Range("C" & (r + i) - 1).Value Then
ActiveSheet.Cells(r + i, 12).Value = 7.5
ElseIf ActiveSheet.Range("C" & r + i).Value = ActiveSheet.Range("C" & (r + i) + 1).Value Then
ActiveSheet.Cells(r + i, 12).Value = 7.5
Else
ActiveSheet.Cells(r + i, 12).Value = 10
End If
Next i
If SD <> ED Then
DateRange = Format(SD, "yyyy-mm-dd") & " through " & Format(ED, "yyyy-mm-dd")
Else
DateRange = Format(SD, "yyyy-mm-dd")
End If
With ActiveWorkbook
For i = 1 To .Sheets.Count
.Sheets(i).Select
.Sheets(i).Range("A2").Value = DateRange
Next
.Sheets("Dermesse Dashboard").Select
End With
On Error GoTo 0
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs ("\\apfssvr01\Arrow_RX\Reports\Dermesse\DERMESSE_Dashboard(" & DateRange & ").xlsx"), FileFormat:=51
Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
frmSwitchboard.lblDD.Caption = "Report Complete"
Exit Sub
CloseConnection:
Application.ScreenUpdating = True
frmSwitchboard.lblDD.Caption = "Error: " & Error
cn.Close
If ActiveWorkbook.Sheets(1).Name <> "Sheet1" Then
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End If
End Sub
Any help would be greatly appreciated

Merge multiple Excel files in one Excel sheet without copying the formulas and duplicating data

I try to merge multiple Excel file in to one master sheet.
The code below works perfect because is not duplicating the merged data. My only issue is that is copying also the formulas from other file ... what I need is only the values.
I try to change some part of the code to
PasteSpecial Paste:=xlPasteValues
Error Image
Error 400 Image
Than I get an error (.
Code Used:
Sub sumit()
Dim fso As New FileSystemObject
Dim NoOfFiles As Double
Dim counter As Integer
Dim r_counter As Integer
Dim s As String
Dim listfiles As Files
Dim newfile As Worksheet
Dim mainworkbook As Workbook
Dim combinedworksheet As Worksheet
Dim tempworkbook As Workbook
Dim rowcounter As Double
Dim rowpasted As Integer
Dim delHeaderRow As Integer
Dim Folderpath As Variant
Dim headerset As Variant
Dim Actualrowcount As Double
Dim x As Long
Dim Delete_Remove_Blank_Rows As String
Range("A:A").Clear
Range("B:B").Clear
Range("C:C").Clear
Folderpath = ActiveWorkbook.Sheets(2).Range("I7").Value
headerset = ActiveWorkbook.Sheets(2).Range("F4").Value
Delete_Remove_Blank_Rows = ActiveWorkbook.Sheets(2).Range("F3").Value
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Dim Files_Count_No_Of_Rows_In_Sheets(1000) As Double 'declare the array of the size of no of files in the folder
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 0
r_counter = 1
rowcounter = 1
Actualrowcount = 0
For Each fls In listfiles
counter = counter + 1
Range("A" & counter).Value = fls.Name
Next
'MsgBox ("count of files in folder is " & NoOfFiles)
Set mainworkbook = ActiveWorkbook
Set combinedworksheet = mainworkbook.Sheets(2)
mainworkbook.Sheets(3).UsedRange.Clear
'MsgBox ("Sheet is clear for the data to be copied")
For i = 1 To NoOfFiles
mainworkbook.Sheets("Combine").Activate
'MsgBox ("Sheet 3 is Activated")
mainworkbook.Sheets("Combine").Range("A" & rowcounter).Select
Application.Workbooks.Open (Folderpath & "\" & Range("A" & i).Value)
Set tempworkbook = ActiveWorkbook
Set newfile = ActiveSheet
rowpasted = rowcounter
'MsgBox ("pointer at " & rowpasted)
newfile.UsedRange.Copy
'MsgBox ("Data is copied")
mainworkbook.Sheets(3).Paste
'MsgBox ("Data is pasted successfully")
'MsgBox ("Blank rows has been deleted " & Remove_Blank_Rows & " " & headerset)
If Delete_Remove_Blank_Rows = "Yes" Then
'If Remove_Blank_Rows = Yes Then
'MsgBox ("Blank rows has been deleted" & Delete_Remove_Blank_Rows)
For x = mainworkbook.Sheets("Combine").Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(mainworkbook.Sheets("Combine").Rows(x)) = 0 Then
mainworkbook.Sheets("Combine").Rows(x).Delete
'MsgBox ("Blank rows has been deleted" & Remove_Blank_Rows)
End If
Next
End If
rowcounter = mainworkbook.Sheets(3).UsedRange.Rows.Count + 1
'MsgBox ("row counter is updated" & rowcounter)
rowpasted = rowcounter - rowpasted
'MsgBox ("No fo rows pasted" & rowpasted)
delHeaderRow = rowcounter - rowpasted
'MsgBox ("Which row to delete" & delHeaderRow)
'MsgBox ("Pointer at row beforw deletion" & rowpasted)
If headerset = "Yes" Or headerset = "YES" Or headerset = "yes" Then
If delHeaderRow <> 1 Then
mainworkbook.Sheets(3).Rows(delHeaderRow).EntireRow.Delete
rowcounter = rowcounter - 1
rowpasted = rowpasted - 1
Else
End If
Else
End If
'MsgBox ("Header deleted")
'MsgBox ("row counter is updated" & rowcounter)
combinedworksheet.UsedRange.ClearOutline
'combinedworksheet.
tempworkbook.Close
'MsgBox ("no of rows are abt to get pasted in sheet 1")
Files_Count_No_Of_Rows_In_Sheets(i) = rowpasted
Actualrowcount = Actualrowcount + rowpasted
Next i
mainworkbook.Sheets(1).UsedRange.ClearContents
For Each fls In listfiles
r_counter = r_counter + 1
mainworkbook.Sheets(1).Range("A" & r_counter).Value = fls.Name
mainworkbook.Sheets(1).Range("B" & r_counter).Value = Files_Count_No_Of_Rows_In_Sheets(r_counter - 1)
mainworkbook.Sheets(1).Range("A" & r_counter, "B" & r_counter).Borders.Value = 1
Next
mainworkbook.Sheets(1).Range("B" & r_counter + 1).Interior.ColorIndex = 46
mainworkbook.Sheets(1).Range("B" & r_counter + 1).Value = Actualrowcount
mainworkbook.Sheets(1).Range("B" & r_counter + 1).Borders.Value = 1
mainworkbook.Sheets(1).Range("A1", "B1").Interior.ColorIndex = 46
mainworkbook.Sheets(1).Range("A1", "B1").Borders.Value = 1
mainworkbook.Sheets(1).Range("A1").Value = "Files List"
mainworkbook.Sheets(1).Range("B1").Value = "No Of Rows"
MsgBox ("List of Files are Availabe in sheet 1..Total " & NoOfFiles & " Files Combiled")
End Sub
In the error image there is mainworkbook.Sheets(3).Paste xlPasteValues which is wrong and should be mainworkbook.Sheets(3).Cells(rowcounter, 1).PasteSpecial xlPasteValues.

How to generate barcodes in excel worksheet

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

VBA Splash Screen

I wonder whether someone may be able to help me please.
I'm trying to put together a script which produces a "Splash" screen whilst a a lengthy Excel macro is being run.
I've done quite a bit of research on this and found an example here.
I've set up my form with the following code in it's properties:
' Set true when the long task is done.
Public TaskDone As Boolean
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = Not TaskDone
End Sub
I've then created a module which contains this piece of code:
Now Removed in Working Code
The problem I have is that I'm really unsure how to integrate this with the macro I want to run whilst the form is displayed.
The code below is the macro I'll be running:
Updated Code - Working Script
Sub CreateAllData()
Dim cell As Range
Dim cll As Range
Dim DestWB As Workbook
Dim dR As Long
Dim excelfile As Variant
Dim Fd As FileDialog
Dim i As Long
Dim LastRow As Long
Dim LR As Long
Dim MidFile As String
Dim MyNames As Variant
Dim sFile As String
Dim sMidFile As Variant
Dim SourceSheet As String
Dim StartRow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim frm As frmSplash
Dim j As Integer
' Display the splash form non-modally.
Set frm = New frmSplash
frm.TaskDone = False
frm.prgStatus.Value = 0
frm.Show False
For j = 1 To 1000
DoEvents
Next j
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
StartRow = 2
sMidFile = "January, February, March, April, May, June, July, August, September, October, November, December"
MidFile = InputBox("Enter the name of the monthly folder e.g. 'January'", "All Time Recording Data")
If InStr(sMidFile, MidFile) = 0 Or MidFile = "" Then
MsgBox "A valid month name was not entered"
End
End If
Application.ScreenUpdating = False
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(1))
newsht.Name = "All Data"
With newsht
With .Range("B5")
.Value = "All Data"
.Offset(2, 0).Resize(, 14).Value = Array("Project LOB", "Resource LOB", "Staff Name", "Task", "Project Name", "Project Code", "Project ID", "Job Role", "Month", "Forecast Hrs", "Forecast FTE", "Actuals Hrs", "Actuals FTE", "Flexible Resource")
End With
End With
Range("B7:O7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Data\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Data").Range("B" & DestWB.Worksheets("All Data").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":M" & LastRow).Copy
DestWB.Worksheets("All Data").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Data").Range("B8:N" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Data").Range("B8:N" & LastRow).Font.Size = 10
DestWB.Worksheets("All Data").Range("K8:N" & LastRow).NumberFormat = "#,##0.00"
DestWB.Worksheets("All Data").Range("K8:N" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 10
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(2))
newsht.Name = "All Projects"
With newsht
With .Range("B5")
.Value = "All Projects"
.Offset(2, 0).Resize(, 7).Value = Array("Project LOB", "Project Name", "Project Code", "Project ID", "Project Priority", "Project Start Date", "Project Finish Date")
End With
End With
Range("B7:H7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Projects\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Projects").Range("B" & DestWB.Worksheets("All Projects").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":G" & LastRow).Copy
DestWB.Worksheets("All Projects").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Projects").Range("B8:H" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Projects").Range("B8:H" & LastRow).Font.Size = 10
DestWB.Worksheets("All Projects").Range("H8:H" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 20
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(3))
newsht.Name = "All Resources"
With newsht
With .Range("B5")
.Value = "All Resources"
.Offset(2, 0).Resize(, 8).Value = Array("Staff Name", "Resource LOB", "Job Role", "Month", "Staff FTE", "Flexible Resource", "Line Manager", "Date of Termination")
End With
End With
Range("B7:I7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Resources\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Resources").Range("B" & DestWB.Worksheets("All Resources").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":E" & LastRow).Copy
DestWB.Worksheets("All Resources").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Resources").Range("B8:I" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Resources").Range("B8:I" & LastRow).Font.Size = 10
DestWB.Worksheets("All Resources").Range("F8:H" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 30
Set sht = Sheets("All Resources")
MyNames = Array("AllResSName", "AllResLOB", "AllResJRole", "AllResPeriod", "AllResFTE", "AllResFlex", "AllResLineM", "AllResTerm")
i = 0
LR = sht.Range("B" & Rows.Count).End(xlUp).Row
For Each cll In Ash.Range("B8:I8").Cells
Range(sht.Cells(8, cll.Column), sht.Cells(LR, cll.Column)).Name = MyNames(i)
i = i + 1
Next cll
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(4))
newsht.Name = "Flexible Resources List"
With newsht
With .Range("B5")
.Value = "Flexible Resources List"
.Offset(2, 0).Resize(, 6).Value = Array("Resource LOB", "Staff Name", "Grade", "Flexible Resource", "Line Manager", "Date of Termination")
End With
End With
Range("B7:G7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\Flexible Resources\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("Flexible Resources List").Range("B" & DestWB.Worksheets("Flexible Resources List").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":G" & LastRow).Copy
DestWB.Worksheets("Flexible Resources List").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("Flexible Resources List").Range("B8:G" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("Flexible Resources List").Range("B8:G" & LastRow).Font.Size = 10
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 40
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(5))
newsht.Name = "IDEAS"
With newsht
With .Range("B5")
.Offset(2, 0).Resize(, 5).Value = Array("Staff Name", "Project Name", "Project ID", "Month", "Actuals FTE")
End With
End With
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\IDEAS\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("IDEAS").Range("B" & DestWB.Worksheets("IDEAS").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":E" & LastRow).Copy
DestWB.Worksheets("IDEAS").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("IDEAS").Range("B8:F" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("IDEAS").Range("B8:F" & LastRow).Font.Size = 10
DestWB.Worksheets("IDEAS").Range("F8:F" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 50
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(6))
newsht.Name = "Profile Data"
With newsht
With .Range("B5")
.Value = "Flexible Resource Profile Data"
.Offset(2, 0).Resize(, 4).Value = Array("Resource LOB", "Staff Name", "Project Name", "Job Role")
End With
.Range("F7").Formula = "=B3"
.Range("G7").Resize(, 13).Formula = "=EOMONTH(F7,0)+1"
With Range("T7")
.Value = "Flexible Resource"
.Offset(, 1).Value = "Line Manager"
.Offset(, 2).Value = "Date of Termination"
End With
End With
Range("B7:V7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\Managers List\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("Profile Data").Range("B" & DestWB.Worksheets("Profile Data").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":Q" & LastRow).Copy
DestWB.Worksheets("Profile Data").Cells(dR, "C").PasteSpecial xlValues
DestWB.Worksheets("Profile Data").Range("B8:V" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("Profile Data").Range("B8:V" & LastRow).Font.Size = 10
DestWB.Worksheets("Profile Data").Range("F8:S" & LastRow).NumberFormat = "#,##0.00"
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 60
Call AllDataSignals
Call AllResourcesSignals
Call IDEASFormat
Call DeleteBlankRowsCopy
Call AllDataFormat
Call AllProjectsFormat
Call AllResourcesFormat
Call FlexibleResourcesListFormat
frm.prgStatus.Value = 100
' Close the splash form.
frm.TaskDone = True
Unload frm
Sheets("Macros").Select
Application.ScreenUpdating = True
End Sub
I just wondered whether someone could possibly look at this please and offer some guidance on how I may integrate the two.
Many thanks and regards
You need to replace this portion of the code:
' Perform the long task.
For i = 0 To 100 Step 10
frm.prgStatus.Value = i
' Waste some time.
For j = 1 To 1000
DoEvents
Next j
Next i
...with your long running code and include the frm.prgStatus.Value = i (or similar) in your code to update the progress bar.
EDIT
If you call your sub from and it is in another module, it will not have direct access to update the progress bar. One option is to pass in the progress bar object as a parameter to your sub, like this:
Public Sub CreateAllData(byref MyProgBar As ProgressBar)
Within your sub, you would update the progress bar by doing something like this:
MyProgBar.Value = 1
You will call your sub like this:
CreateAllData frm.prgStatus

Resources