Scenario
I have a word document where I have a table as shown in Image 1. The checkboxes are used to show the next contents. For example, I have in first step yes and no, when yes is checked the next content is shown. And in next step, I have thre Checkboxes with case 1,2 and 3 respectively.
When the case 1 is checked I have next a text that is filled via vba as F1Feld1...till F4Feld1.
Problem
First problem is, I am unable to create a function where only yes and no can be checked as well as either of the case can be checked. Second, problem is that the vba for case checkboxes run perfectly when I have them created separate but when combined together only case 1 vba runs.
Following is my code:
Option Explicit
Dim tabelle As Table, zelle As Cell
Private Sub Document_ContentControlOnEnter(ByVal CC As ContentControl)
Dim r As Range
Set tabelle = ActiveDocument.Bookmarks("local").Range.Tables(1)
If ActiveDocument.SelectContentControlsByTag("Yes").Item(1).Checked = True Then
ActiveDocument.SelectContentControlsByTag("No").Item(1).Checked = False
Call local_blockiert
Else: Call local_offen
End If
If ActiveDocument.SelectContentControlsByTag("Case1").Item(1).Checked = True Then
On Error Resume Next
With ActiveDocument
.Bookmarks("TB1").Range.Text = "F1Feld1": .Bookmarks("TB1").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB2").Range.Text = "F1Fed2": .Bookmarks("TB2").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB3").Range.Text = "F1Feld3": .Bookmarks("TB3").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB4").Range.Text = "F1Feld4": .Bookmarks("TB4").Range.Font.ColorIndex = wdBlack
End With
ElseIf ActiveDocument.SelectContentControlsByTag("Case1").Item(1).Checked = False Then
With ActiveDocument
.Bookmarks("TB1").Range.Text = ""
.Bookmarks("TB2").Range.Text = ""
.Bookmarks("TB3").Range.Text = ""
.Bookmarks("TB4").Range.Text = ""
End With
ElseIf ActiveDocument.SelectContentControlsByTag("Case2").Item(1).Checked = True Then
With ActiveDocument
.Bookmarks("TB1").Range.Text = "F2Feld1": .Bookmarks("TB1").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB2").Range.Text = "F2Fed2": .Bookmarks("TB2").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB3").Range.Text = "F2Feld3": .Bookmarks("TB3").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB4").Range.Text = "F2Feld4": .Bookmarks("TB4").Range.Font.ColorIndex = wdBlack
End With
ElseIf ActiveDocument.SelectContentControlsByTag("Case2").Item(1).Checked = False Then
With ActiveDocument
.Bookmarks("TB1").Range.Text = ""
.Bookmarks("TB2").Range.Text = ""
.Bookmarks("TB3").Range.Text = ""
.Bookmarks("TB4").Range.Text = ""
End With
ElseIf ActiveDocument.SelectContentControlsByTag("Case3").Item(1).Checked = True Then
With ActiveDocument
.Bookmarks("TB1").Range.Text = "F3Feld1": .Bookmarks("TB1").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB2").Range.Text = "F3Fed2": .Bookmarks("TB2").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB3").Range.Text = "F3Feld3": .Bookmarks("TB3").Range.Font.ColorIndex = wdBlack
.Bookmarks("TB4").Range.Text = "F3Feld4": .Bookmarks("TB4").Range.Font.ColorIndex = wdBlack
End With
ElseIf ActiveDocument.SelectContentControlsByTag("Case3").Item(1).Checked = False Then
With ActiveDocument
.Bookmarks("TB1").Range.Text = ""
.Bookmarks("TB2").Range.Text = ""
.Bookmarks("TB3").Range.Text = ""
.Bookmarks("TB4").Range.Text = ""
End With
End If
End Sub
Private Sub local_blockiert()
Dim i As Long, j As Long
On Error GoTo fehler
With ActiveDocument.Bookmarks("local").Range
.Font.ColorIndex = wdWhite
End With
fehler:
Call AllesAuf
End Sub
Private Sub local_offen()
Dim i As Long, j As Long
On Error GoTo fehler
With ActiveDocument.Bookmarks("YesorNo").Range
.Font.ColorIndex = wdBlack
End With
fehler:
Call AllesAuf
End Sub
Private Sub yes_blockiert()
Dim j As Long
On Error GoTo fehler
With tabelle.Cell(2, 2)
.Shading.ForegroundPatternColorIndex = wdGray25
.Range.Font.ColorIndex = wdGray25
For j = 1 To .Range.ContentControls.Count
.Range.ContentControls(j).LockContents = True
Next j
End With
Exit Sub
fehler:
Call AllesAuf
End Sub
Private Sub yes_offen()
Dim j As Long
On Error GoTo fehler
With tabelle.Cell(2, 2)
For j = 1 To .Range.ContentControls.Count
.Range.ContentControls(j).LockContents = False
Next j
.Shading.ForegroundPatternColor = RGB(255, 242, 204)
.Range.Font.ColorIndex = wdAuto
End With
Exit Sub
fehler:
Call AllesAuf
End Sub
Private Sub AllesAuf()
Dim i As Long
With ActiveDocument
For i = 1 To .ContentControls.Count
.ContentControls(i).LockContents = False
Next i
End With
End Sub
Related
I am quite new to vba and I need to write a script that has as input a document with some revisions. For each paragraph i would like to have in a table the original text (no revisions) and the final text (as if all revisions have been accepted). If this is to difficult I would like to at least have a table that contains the new text, the number of the paragraph in the original document and the number of the paragraph in the final version
Here an example of how could look like the input of the script
Here what i would like to have as output
Here what I have been able to do. I am not able to get the original text and in case of multiple phrases insertion the script is able to recognize only the first one as new line.
The script go through all the paragraph, if the paragraph contains no revision just the text is added in the table. If the text contains at list one revision all except the last revision are accepted and if the last the revision is an insert then if the paragraph text before and after all revisions have been accepted is the same the next paragraph is considered as new line. If the last revision is a delete then if the paragraph text before all revisions have been accepted is equal to the text of reviosion the text paragraph is considered as interely deleted.
Sub TrackchangesTable()
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim oCol As Column
Dim oRange As Range
Dim oRevision As Revision
Dim strText As String
Dim Title As String
Dim Para As Paragraph
Dim NewLine As Boolean
Dim DraftText As String
Dim NewId As Long
Dim OldId As Long
Dim OldText As String
Dim Stile As String
Dim OriginalDoc As Document
Set oDoc = ActiveDocument
If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.", vbOKOnly, Title
GoTo ExitHere
Else
If MsgBox("Do you want to extract tracked changes to a new document?" & vbCr & vbCr & , _
vbYesNo + vbQuestion) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
Set oNewDoc = Documents.Add
oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
.Content = ""
With .PageSetup
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.TopMargin = CentimetersToPoints(2.5)
End With
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=7)
End With
With oNewDoc.Styles(wdStyleNormal)
With .Font
.Name = "Arial"
.Size = 9
.Bold = False
End With
With .ParagraphFormat
.LeftIndent = 0
End With
End With
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
For Each oCol In .Columns
oCol.PreferredWidthType = wdPreferredWidthPercent
Next oCol
.Columns(1).PreferredWidth = 5 'Page
.Columns(2).PreferredWidth = 5 'Note
.Columns(3).PreferredWidth = 10 'Final Text
.Columns(4).PreferredWidth = 15 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Old Id
.Columns(6).PreferredWidth = 10 'New ID
.Columns(7).PreferredWidth = 10 'Stile
End With
With oTable.Rows(1)
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Note"
.Cells(3).Range.Text = "Final Text"
.Cells(4).Range.Text = "Deleted Text"
.Cells(5).Range.Text = "Old Id"
.Cells(6).Range.Text = "New Id"
.Cells(7).Range.Text = "stile"
End With
NewLine = False
OldId = 1
NewId = 1
For Each Para In ThisDocument.Paragraphs
Stile = Para.Range.Style
If Para.Range.Revisions.Count = 0 And NewLine = False Then
StrTextFinale = Para.Range.Text
ElseIf Para.Range.Revisions.Count = 0 And NewLine = True Then
StrTextFinale = Para.Range.Text
Note = "New Line"
NewLine = False
OldId = OldId - 1
ElseIf Para.Range.Revisions.Count > 0 Then
For i = 1 To Para.Range.Revisions.Count
If i < Para.Range.Revisions.Count Then
Para.Range.Revisions(i).Accept
Else
If Para.Range.Revisions(i).Type = wdRevisionInsert Then
DraftText = Para.Range.Text
Para.Range.Revisions(i).Accept
StrTextFinale = Para.Range.Text
If DraftText = StrTextFinale Then
NewLine = True
End If
ElseIf Para.Range.Revisions(i).Type = wdRevisionDelete Then
DraftText = Para.Range.Revisions(i).Range.Text
StrTextFinale = Para.Range.Text
If DraftText = StrTextFinale Then
Note = "Testo eliminato"
StrTextFinale = "volutamente cancellato"
OldText = Para.Range.Text
NewId = NewId - 1
Else
Para.Range.Revisions(i).Accept
StrTextFinale = Para.Range.Text
End If
End If
End If
Next
End If
Set oRow = oTable.Rows.Add
With oRow
.Cells(1).Range.Text = Para.Range.Information(wdActiveEndAdjustedPageNumber)
.Cells(2).Range.Text = Note
.Cells(3).Range.Text = StrTextFinale
.Cells(4).Range.Text = OldText
.Cells(5).Range.Text = OldId
.Cells(6).Range.Text = NewId
.Cells(7).Range.Text = Stile
Note = ""
End With
OldId = OldId + 1
NewId = NewId + 1
OldText = ""
Next
With oTable.Rows(1)
.Range.Font.Bold = True
.HeadingFormat = True
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox ("Over")
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing
End Sub
Can somebody help me to improve this script?
Set SapGuiAuto = GetObject("SAPGUI")
Set SapApp = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(Connection) Then
Set Connection = SapApp.Children(0)
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject SapApp, "on"
End If
Dim SO_ref As String
Dim PO_order As String
Dim ship_cond As String
Dim antal As Integer
Dim i As Integer
antal = Range("F8").Value
Range("E11:E40").Clear
If OPT_Cust1.Value = True Then
SO_ref = Range("F2").Value
PO_order = Range("G2").Value
ship_cond = Range("H2").Value
Else
End If
If OPT_Cust2.Value = True Then
SO_ref = Range("F3").Value
PO_order = Range("G3").Value
ship_cond = Range("H3").Value
End If
If Cust3.Value = True Then
SO_ref = Range("F4").Value
PO_order = Range("G4").Value
ship_cond = Range("H4").Value
End If
If Cust4.Value = True Then
SO_ref = Range("F5").Value
PO_order = Range("G5").Value
ship_cond = Range("H5").Value
End If
i = 1
Do While i < antal + 1
session.findById("wnd[0]").resizeWorkingPane 160, 38, False
'session.createSession
session.findById("wnd[0]/tbar[0]/okcd").Text = "va01"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/ctxtVBAK-AUART").Text = "ABC1" ' Order Type
session.findById("wnd[0]/usr/ctxtVBAK-VKORG").Text = "xxxx"
session.findById("wnd[0]/usr/ctxtVBAK-VTWEG").Text = "xx"
session.findById("wnd[0]/usr/ctxtVBAK-SPART").Text = "xx"
session.findById("wnd[0]/usr/ctxtVBAK-VKBUR").Text = "xxxx"
session.findById("wnd[0]/usr/ctxtVBAK-VKGRP").Text = "xxx"
I got this script for creation of SO "headers". Currently it working fine but I need to add one more customer for which Order type will be different.
Say if the Cust4 is selected then the Order Type should be ABC2 otherwise it should always choose ABC1.
How can this function be added to the script?
Try the next approach, please:
Dim boolType2 as Boolean
'...your existing code
If Cust4.Value = True Then
boolType2 = True
SO_ref = Range("F5").Value
PO_order = Range("G5").Value
ship_cond = Range("H5").Value
End If
'...your existing code
session.findById("wnd[0]/usr/ctxtVBAK-AUART").Text = _
IIf(boolType2 = True, "ABC2", "ABC1")
'...your existing code
You can create such boolean variables for many other types, if necessary... IIf supports imbricate functions.
Edited:
If your above used controls are check boxes, your code must check if only one of them would be checked. Otherwise, the code will take the values from the last (ticked) one...
If the check boxes are ActiveX type, you can use each of them Change event, in order to un-tick the others. If not, try adapting your code in the next way, which will do the same thing, but less elegant (on my taste)...
If OPT_Cust1.Value = True Then
If OPT_Cust2.Value = True Or _
Cust3.Value = True Or _
Cust4.Value = True Then _
MsgBox "Another check box is also ticked!": Exit Sub
SO_ref = Range("F2").Value
PO_order = Range("G2").Value
ship_cond = Range("H2").Value
ElseIf OPT_Cust2.Value = True Then
If Cust3.Value = True Or Cust4.Value = True Then _
MsgBox "Another check box is also ticked!": Exit Sub
SO_ref = Range("F3").Value
PO_order = Range("G3").Value
ship_cond = Range("H3").Value
ElseIf Cust3.Value = True Then
If Cust4.Value = True Then _
MsgBox "Cust4 check box is also ticked!": Exit Sub
SO_ref = Range("F4").Value
PO_order = Range("G4").Value
ship_cond = Range("H4").Value
ElseIf Cust4.Value = True Then
boolType2 = True
SO_ref = Range("F5").Value
PO_order = Range("G5").Value
ship_cond = Range("H5").Value
End If
Just add variable of "Order Type" and set it for every Cust to your SAP scipt.
If Cust4.Value = True Then
SO_ref = Range("F5").Value
PO_order = Range("G5").Value
ship_cond = Range("H5").Value
Type = "ABCD2"
End If
session.findById("wnd[0]/usr/ctxtVBAK-AUART").Text = Type ' Order Type
Hope I've helped.
Have a great day :).
Could anyone help me to modify the script below to do the following:
Currently if there is an image with the same name in two different folders and with two different sizes, the program will completely skip the image if the first version found does not match the file size required.
I would like it to skip the small size image however if it comes across the same name in another folder with the right image size, it would copy it.
Here is the full program code:
Option Explicit
Const fileListRow = 1
Const fileListCol = 2
Const srcDirRow = 2
Const srcDirCol = 2
Const destDirRow = 3
Const destDirCol = 2
Const resultRow = 4
Const resultListCol = 1
Const resultFoundCol = 2
Const resultCopyCol = 3
Const percentageRow = 5
Const percentageCol = 4
Const fileSizeLimitRow = 4
Const fileSizeLimitCol = 5
Dim srcFileShortName As String
Dim srcFileFullName As String
Dim destFileFullName As String
Dim srcDir As String
Dim destDir As String
Const startRowSrcFileShortName = 7
Dim endRowSrcFileShortName As Long
Const startRowSrcFileFullName = 7
Const startColSrcFileFullName = 2
Dim endRowSrcFileFullName As Long
Dim searchFileAmount As Long
Dim foundFileAmount As Long
Dim copyFileAmount As Long
Dim fileSizeLimit As Long
Dim totalCopyFileSize As Long
Dim currentCopyFileSize As Long
Dim mainWS As Worksheet
Sub getFileList()
Set mainWS = ThisWorkbook.Sheets("main")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainWS.Unprotect
Dim x As Variant
x = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt", Title:="Choose File List", MultiSelect:=False)
If x = False Then
Exit Sub
End If
ThisWorkbook.Sheets("main").Cells(fileListRow, fileListCol).Value = x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
mainWS.Protect
End Sub
Sub getSrcDir()
Set mainWS = ThisWorkbook.Sheets("main")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainWS.Unprotect
Dim folderPath As String
Dim result As Integer
Dim dialog As Office.FileDialog
Set dialog = Application.FileDialog(msoFileDialogFolderPicker)
dialog.InitialFileName = ""
result = dialog.Show()
If result = -1 Then
ThisWorkbook.Sheets("main").Cells(srcDirRow, srcDirCol).Value = dialog.SelectedItems(1)
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
mainWS.Protect
End Sub
Sub getDestDir()
Set mainWS = ThisWorkbook.Sheets("main")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainWS.Unprotect
Dim folderPath As String
Dim result As Integer
Dim dialog As Office.FileDialog
Set dialog = Application.FileDialog(msoFileDialogFolderPicker)
dialog.InitialFileName = ""
result = dialog.Show()
If result = -1 Then
ThisWorkbook.Sheets("main").Cells(destDirRow, destDirCol).Value = dialog.SelectedItems(1)
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
mainWS.Protect
End Sub
Sub resetField()
Dim totalRow As Long
Set mainWS = ThisWorkbook.Sheets("main")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainWS.Unprotect
mainWS.Cells(resultRow, resultListCol).Resize(1, 3).ClearContents
mainWS.Cells(percentageRow, percentageCol).Resize(1, 3).ClearContents
endRowSrcFileShortName = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).Row
totalRow = endRowSrcFileShortName - startRowSrcFileShortName + 1
If totalRow > 0 Then
mainWS.Cells(startRowSrcFileShortName, 1).Resize(totalRow, 3).ClearContents
mainWS.Cells(startRowSrcFileShortName, 1).Resize(totalRow, 3).Interior.ColorIndex = xlColorIndexNone
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
mainWS.Protect
End Sub
Sub FindFile()
Call resetField
Dim counter As Long
Set mainWS = ThisWorkbook.Sheets("main")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainWS.Unprotect
Dim fileName As String, textRow As String, fileNo As Integer
fileName = mainWS.Cells(fileListRow, fileListCol)
fileNo = FreeFile 'Get first free file number
counter = startRowSrcFileShortName
Open fileName For Input As #fileNo
Do While Not EOF(fileNo)
Line Input #fileNo, textRow
mainWS.Cells(counter, 1).Value = textRow
counter = counter + 1
Loop
Close #fileNo
srcDir = mainWS.Cells(srcDirRow, srcDirCol).Value
endRowSrcFileShortName = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).Row
searchFileAmount = 0
For counter = startRowSrcFileShortName To endRowSrcFileShortName
srcFileShortName = mainWS.Cells(counter, 1).Value
If srcFileShortName <> "" Then
searchFileAmount = searchFileAmount + 1
End If
Next counter
mainWS.Cells(resultRow, 1).Value = searchFileAmount & " Files Searched"
If searchFileAmount > 0 Then
foundFileAmount = 0
For counter = startRowSrcFileShortName To endRowSrcFileShortName
srcFileShortName = mainWS.Cells(counter, 1).Value
If srcFileShortName <> "" Then
srcFileFullName = ""
Call FindFileName1(srcDir)
Call FindFileName2(srcDir)
If srcFileFullName = "" Then
mainWS.Cells(counter, startColSrcFileFullName).Value = "N/A"
mainWS.Cells(counter, startColSrcFileFullName).Interior.Color = RGB(255, 0, 0)
Else
mainWS.Cells(counter, startColSrcFileFullName).Value = srcFileFullName
foundFileAmount = foundFileAmount + 1
End If
Else
mainWS.Cells(counter, startColSrcFileFullName).Value = "N/A"
End If
Next counter
End If
mainWS.Cells(resultRow, resultFoundCol).Value = foundFileAmount & " Files Found"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
mainWS.Protect
End Sub
Private Function FindFileName1(srcDir) '²éÕÒԴ·¾¶
Dim fso, fld, fsb
Dim fd, f
If srcFileFullName <> "" Then Exit Function 'ÕÒµ½ºóÍ˳ö
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(srcDir)
For Each f In fld.Files '±éÀúÔ´Îļþ¼ÐÖеÄËùÓÐÎļþ
If CaseCheckBox.Value = True Then
If f.Name = srcFileShortName Then '±È½ÏÁ½¸öÎļþÃû£¬Çø·Ö´óСд
srcFileFullName = fld.Path & "\" & f.Name
Exit Function 'ÕÒµ½ºóÍ˳ö
End If
Else
If UCase(f.Name) = UCase(srcFileShortName) Then '±È½ÏÁ½¸öÎļþÃû,²»Çø·Ö´óСд
srcFileFullName = fld.Path & "\" & f.Name
Exit Function 'ÕÒµ½ºóÍ˳ö
End If
End If
Next
End Function
Private Function FindFileName2(srcDir) 'µÝ¹éËÑÑ°´úÂë
Dim fso, fld, fsb
Dim fd, f
If srcFileFullName <> "" Then Exit Function 'ÕÒµ½ºóÍ˳öµÝ¹é
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(srcDir)
Set fsb = fld.SubFolders
For Each fd In fsb '±éÀú¸ÃÎļþ¼ÐµÄËùÓÐ×ÓÎļþ¼Ð
For Each f In fd.Files '±éÀúÿ¸ö×ÓÎļþ¼ÐÖеÄËùÓÐÎļþ
If CaseCheckBox.Value = True Then
If f.Name = srcFileShortName Then '±È½ÏÁ½¸öÎļþÃû£¬Çø·Ö´óСд
srcFileFullName = fd.Path & "\" & f.Name
Exit Function 'ÕÒµ½ºóÍ˳öµÝ¹é
End If
Else
If UCase(f.Name) = UCase(srcFileShortName) Then '±È½ÏÁ½¸öÎļþÃû,²»Çø·Ö´óСд
srcFileFullName = fd.Path & "\" & f.Name
Exit Function 'ÕÒµ½ºóÍ˳öµÝ¹é
End If
End If
Next
Call FindFileName2(fd.Path) '±¾Îļþ¼Ð¼ì²éÍê±Ïºó£¬¼ÌÐøÉî²ãËÑËØÆä×ÓÎļþ¼Ð
Next
End Function
Sub CopyFile()
Dim counter As Long
Dim fileSize As Long
Set mainWS = ThisWorkbook.Sheets("main")
'Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainWS.Unprotect
srcDir = mainWS.Cells(srcDirRow, srcDirCol).Value
endRowSrcFileFullName = mainWS.Cells(mainWS.Rows.Count, startColSrcFileFullName).End(xlUp).Row
copyFileAmount = 0
fileSizeLimit = mainWS.Cells(fileSizeLimitRow, fileSizeLimitCol).Value * 1024 * 1024
totalCopyFileSize = 0
currentCopyFileSize = 0
If foundFileAmount > 0 Then
For counter = startRowSrcFileFullName To endRowSrcFileFullName
srcFileFullName = mainWS.Cells(counter, startColSrcFileFullName).Value
If srcFileFullName <> "N/A" Then
fileSize = FileLen(srcFileFullName)
If fileSize >= fileSizeLimit Then
totalCopyFileSize = totalCopyFileSize + fileSize
End If
End If
Next counter
End If
If foundFileAmount > 0 Then
For counter = startRowSrcFileFullName To endRowSrcFileFullName
srcFileFullName = mainWS.Cells(counter, startColSrcFileFullName).Value
If srcFileFullName <> "N/A" Then
fileSize = FileLen(srcFileFullName)
If fileSize >= fileSizeLimit Then
destFileFullName = mainWS.Cells(destDirRow, destDirCol) & "\" & mainWS.Cells(counter, 1)
On Error Resume Next
FileCopy srcFileFullName, destFileFullName
If Err.Number <> 0 Then
mainWS.Cells(counter, resultCopyCol) = "Error"
mainWS.Cells(counter, resultCopyCol).Interior.Color = RGB(255, 0, 0)
Else
mainWS.Cells(counter, resultCopyCol) = "OK"
copyFileAmount = copyFileAmount + 1
currentCopyFileSize = currentCopyFileSize + fileSize
mainWS.Cells(percentageRow, percentageCol).Value = currentCopyFileSize / totalCopyFileSize
End If
Else
mainWS.Cells(counter, resultCopyCol) = "FileSize:" & fileSize & "Bytes,Skipped"
End If
End If
Next counter
End If
mainWS.Cells(resultRow, resultCopyCol).Value = copyFileAmount & " Files Copied"
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
mainWS.Protect
End Sub
I want to determine if something has changed in a catpart that would drive a change in a body, but the change hasnt been done because update is set to manual.
I have tried:
if part.product.update = true then
'do something
else
'do something else
endif
However this just forces an update and doesnt tell me if one was required.
I worked out a solution (see below)
'#####################
Function func_CheckNoModsSinceLastSaved() As Boolean
func_CheckNoModsSinceLastSaved = False
Dim flg_NoModsSinceLastSaved As Boolean
flg_NoModsSinceLastSaved = False
If Right(CATIA.ActiveDocument.FullName, 11) = ".CATProduct" Then
Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument
Dim product1 As Product
Set product1 = productDocument1.Product
flg_NoModsSinceLastSaved = productDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
product1.Update
flg_NoModsSinceLastSaved = productDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
Set productDocument1 = Nothing
ElseIf Right(CATIA.ActiveDocument.FullName, 8) = ".CATPart" Then
Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument
flg_NoModsSinceLastSaved = partDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
partDocument1.Part.Update
flg_NoModsSinceLastSaved = partDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
Set partDocument1 = Nothing
ElseIf Right(CATIA.ActiveDocument.FullName, 11) = ".CATDrawing" Then
Dim drawingDocument1 As DrawingDocument
Set drawingDocument1 = CATIA.ActiveDocument
flg_NoModsSinceLastSaved = drawingDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
drawingDocument1.Update
flg_NoModsSinceLastSaved = drawingDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
Set drawingDocument1 = Nothing
Else
MsgBox "ERROR: Unidentified File Type!", vbCritical + vbOKOnly, ""
End If
End Function
'#####################
Check CATIA Settings
Set mySettControlers = CATIA.SettingControllers
Set myPartInfraSetting = mySettControlers.Item("CATMmuPartInfrastructureSettingCtrl")
Check how is set myPartInfraSetting.UpdateMode and see if is catManualUpdate or catAutomaticUpdate
In one excel instance (Instance A), my workbook (Workbook A) performs calculations based on user inputs and creates a worksheet with a chart object. This worksheet is copied and pasted into another workbook (Workbook B), which is closed in Instance A and then opened in a second excel instance (Instance B). Workbook B/Instance B are kept open and in a separate window, as the function of Workbook A/Instance A is to create worksheets to be viewed in Workbook B/Instance B.
So the macro process is: Worksheet is created in Instance A/Workbook A -> Workbook B is closed in Instance B -> Workbook B is opened in Instance A -> worksheet is copied from Workbook A to Workbook B -> Workbook B is saved/closed in Instance A -> Workbook B is opened in Instance B
In the interest of full disclosure, this is the entire sub:
Sub CopySSToNewWorkbook()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim MoveFromWkb As Workbook
Dim MoveFromSht As Worksheet
Dim ChartName As String
Dim RngToCover As Range
Dim duplicateChtPic As Shape
Dim NewSheetName As String
Dim TagString As String
If InputPage.Range("PanelTag") <> "" Then TagString = "-" & InputPage.Range("PanelTag").Text
Set MoveFromWkb = ThisWorkbook
'Set MoveFromSht = MoveFromWkb.Sheets("InputPage")
If InputPage.Range("PgNum") <> "" Then
NewSheetName = InputPage.Range("RoomNum").Text & TagString & " (Pg" & InputPage.Range("PgNum") & ")"
Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
Else
NewSheetName = InputPage.Range("RoomNum").Text & TagString
Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
End If
Set RngToCover = MoveFromSht.Range("E19:Y34")
ChartName = "Panel" & InputPage.Range("PgNum")
'Duplicate method
Set duplicateChtPic = MoveFromSht.ChartObjects(ChartName).Duplicate()
MoveFromSht.Shapes(ChartName).Delete
duplicateChtPic.ZOrder msoSendToBack
duplicateChtPic.Select
Call DelinkChartFromData
With duplicateChtPic
.height = RngToCover.height ' resize
.Width = RngToCover.Width ' resize
.top = RngToCover.top - 2 ' reposition
.Left = RngToCover.Left - 6 ' reposition
End With
MoveFromSht.Shapes("SaveSpoolSheetButton").Delete
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoTrue
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoTrue
MoveFromSht.Shapes("DeletePanelButton").Visible = msoTrue
Dim CNumber As String
Dim RelNum As String
Dim CrtNum As String
Dim Percentage As String
Dim SSFolderName As String
Dim Wkbname As String
Dim FileLocation As String
Dim Sht As Worksheet
Dim SSCopyYesNo As Integer
Dim DoubleSheet As Boolean
Dim MoveToWkb As Workbook
Dim MoveToSht As Worksheet
Dim PasteSheet As Worksheet
Dim CellName As name
Dim SheetCounter As Integer
SheetCounter = 1
Dim i As Integer
Dim varLinks As Variant
With InputPage
CNumber = .Range("JNumber").Text
CrtNum = "Crt" & .Range("CrateNum").Text
RelNum = "Rel" & .Range("RelNum").Text
Percentage = (.Range("RelPct").value * 100) & "Pct"
End With
If CNumber <> "" Then
Wkbname = Wkbname & CNumber
End If
If RelNum <> "Rel" Then
Wkbname = Wkbname & "_" & RelNum
End If
If CrtNum <> "Crt" Then
Wkbname = Wkbname & "_" & CrtNum
End If
If Percentage <> "0Pct" Then
Wkbname = Wkbname & "_" & Percentage
End If
SSFolderName = CreateSSFolders
FileLocation = SSFolderName & "\" & Wkbname & ".xlsb"
Dim newXL As Excel.Application
'Set newXL = GetObject(FileLocation).Application
If IsFileOpen(FileLocation) = True Then
Set newXL = GetObject(FileLocation).Application
newXL.Application.ScreenUpdating = False
newXL.DisplayAlerts = False
newXL.Application.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
' newXL.Application.Quit
' Set newXL = Nothing
Else
Set newXL = CreateObject("Excel.Application")
newXL.Visible = True
End If
If FileFolderExists(FileLocation) Then
' newXL.Application.ScreenUpdating = False
' newXL.Application.DisplayAlerts = False
' On Error Resume Next
' newXL.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
' On Error GoTo 0
Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
Set MoveToWkb = Workbooks(Wkbname & ".xlsb")
Else
Workbooks.Open (InputPage.MainFolderLocation.Text & "calc_and_trans\SpoolSheetWorkbookTemplate.xlsb")
Set MoveToWkb = Workbooks("SpoolSheetWorkbookTemplate.xlsb")
'if SSFolder doesn't already exist, the EditSpoolSheet module is imported to the new spoolsheet
'it is also exported to update any changes made
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromWkb.VBProject.VBComponents("EditSpoolSheet").export InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
MoveToWkb.VBProject.VBComponents.Import InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
Else
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoFalse
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoFalse
MoveFromSht.Shapes("CancelEditButton").Visible = msoFalse
MoveFromSht.Shapes("DeletePanelButton").Visible = msoFalse
End If
End If
For Each CellName In MoveToWkb.Names
If Right(CellName.name, 10) <> "Print_Area" Then
CellName.Delete
End If
Next
Dim NewPgNum As String
Dim OldPgNum As String
Dim startRead As Integer
Dim continueRun As Boolean
continueRun = False
NewPgNum = InputPage.Range("PgNum")
For Each Sht In MoveToWkb.Worksheets
startRead = InStr(Sht.name, "(Pg")
If Mid(Sht.name, startRead + 3) = (Right(MoveFromSht.name, Len(NewPgNum) + 1)) And DoubleSheet = False Then
DoubleSheet = True
Application.ScreenUpdating = True
SSCopyYesNo = MsgBox("Do you want to overwrite " & Sht.name & "?", vbYesNo + vbQuestion)
Application.ScreenUpdating = False
If SSCopyYesNo = vbYes Then
Dim spoolPosition As Integer
spoolPosition = Sht.Index
Sht.name = "_"
'attaching a macro to the edit spool sheet button
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
End If
MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
MoveFromSht.Copy After:=MoveToWkb.Sheets(spoolPosition)
Application.DisplayAlerts = False
Sht.Delete
Application.CutCopyMode = False
continueRun = True
End If
ElseIf DoubleSheet <> True Then
DoubleSheet = False
End If
SheetCounter = SheetCounter + 1
Next
If DoubleSheet = False Then
Set PasteSheet = Workbooks(MoveToWkb.name).Worksheets.Add
' MoveFromSht.Copy before:=MoveToWkb.Sheets(1)
'attaching a macro to the edit spool sheet button
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
End If
MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
MoveFromSht.Copy After:=MoveToWkb.Sheets(SheetCounter)
Application.CutCopyMode = False
continueRun = True
End If
If continueRun Then
For Each Sht In MoveToWkb.Worksheets
If Mid(Sht.name, 1, 5) = "Sheet" Then
Application.DisplayAlerts = False
Sht.Delete
End If
Next
Set MoveToSht = MoveToWkb.Sheets(MoveFromSht.name)
Dim moveToShtName As String
moveToShtName = MoveToSht.name
'fix in here
For Each CellName In MoveToWkb.Names
If Right(CellName.name, 10) <> "Print_Area" Then
Application.DisplayAlerts = False
CellName.Delete
End If
Next
Application.PrintCommunication = False
MoveToSht.DisplayPageBreaks = False
'For Each Sht In MoveToWkb.Worksheets
With MoveToSht.PageSetup
.PrintArea = "$A$1:$Z$36"
.Orientation = xlLandscape
.PaperSize = xlPaperLetter
.BlackAndWhite = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftMargin = Application.InchesToPoints(1.6)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.CenterHorizontally = True
.CenterVertically = True
End With
Application.PrintCommunication = True
'%%%%%%%%new crate code %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'******************* Update Crate Sheet Info **************************************'
Dim crateSht As Worksheet
Dim frontSht As Worksheet
Set crateSht = MoveToWkb.Sheets("Crate_List")
Set frontSht = MoveToWkb.Sheets("FrontSheet")
Dim writeRow As Integer
Dim continueToEnd As Boolean
Dim roomColumn As Integer, pageColumn As Integer, sizeColumn As Integer, widthColumn As Integer, typeColumn As Integer, tagColumn As Integer
Dim infoTableCol As Integer
Dim colStep As Integer
For colStep = 1 To 15
Select Case crateSht.Cells(1, colStep).Text
Case "ROOM #"
roomColumn = colStep
Case "PAGE #"
pageColumn = colStep
Case "PANEL SIZE"
sizeColumn = colStep
Case "PANEL WIDTH"
widthColumn = colStep
Case "SQFT"
infoTableCol = colStep
Case "PANEL TYPE"
typeColumn = colStep
Case "PANEL TAG"
tagColumn = colStep
End Select
Next
'if first spoolsheet being added, set constant values (job name, job number etc.)
If MoveToWkb.Sheets.count = 3 Then
frontSht.Cells(5, 6) = MoveToSht.Range("AK2")
frontSht.Cells(6, 6) = MoveToSht.Range("AK3")
Dim EventsState As Boolean
EventsState = Application.EnableEvents
Application.EnableEvents = False
frontSht.Cells(6, 12) = MoveToSht.Range("AK7")
Application.EnableEvents = EventsState
End If
'determines where to write panel data: if row is blank, if Page # being written and read are both "" and panel tag/room # match, and if page numbers are not "" and match
For writeRow = 2 To 500
If Len(crateSht.Range("A" & writeRow).value) = 0 Or (InputPage.Range("PgNum") = "" And crateSht.Cells(writeRow, pageColumn).value = "" And crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value And _
crateSht.Cells(writeRow, tagColumn).value = InputPage.Range("PanelTag").value) Or (InputPage.Range("PgNum").value <> "" And _
InputPage.Range("PgNum").value = crateSht.Cells(writeRow, pageColumn).value) Then
'If continueToEnd Then
Exit For
End If
Next
Dim panelCrateData(24) As Variant
Dim panelTableData As Variant
panelTableData = MoveToSht.Range("AK1:AK39")
'writing spoolsheet information to crate sheet
With MoveToSht
If roomColumn <> 0 Then crateSht.Cells(writeRow, roomColumn) = panelTableData(22, 1) '.Range("AK22")
If pageColumn <> 0 Then crateSht.Cells(writeRow, pageColumn) = panelTableData(21, 1) '.Range("AK21")
If sizeColumn <> 0 Then crateSht.Cells(writeRow, sizeColumn) = panelTableData(13, 1) '.Range("AK13")
If widthColumn <> 0 Then crateSht.Cells(writeRow, widthColumn) = panelTableData(12, 1) ' .Range("AK12")
If tagColumn <> 0 Then crateSht.Cells(writeRow, tagColumn) = panelTableData(24, 1)
If typeColumn <> 0 Then crateSht.Cells(writeRow, typeColumn) = panelTableData(23, 1)
panelCrateData(0) = Round(CDbl(Replace(.Range("X35").Text, "SQFT", "")), 2)
panelCrateData(1) = panelTableData(15, 1) '.Range("AK15")
panelCrateData(2) = panelTableData(14, 1) '.Range("AK14")
panelCrateData(3) = panelTableData(17, 1) '.Range("AK17")
panelCrateData(4) = panelTableData(16, 1) '.Range("AK16")
panelCrateData(5) = panelTableData(18, 1) '.Range("AK18")
panelCrateData(6) = panelTableData(20, 1) '.Range("AK20")
panelCrateData(7) = panelTableData(19, 1) '.Range("AK19")
panelCrateData(8) = panelTableData(25, 1) '.Range("AK23")
panelCrateData(9) = panelTableData(26, 1) '.Range("AK24")
panelCrateData(10) = panelTableData(27, 1) '.Range("AK25")
panelCrateData(11) = panelTableData(29, 1) '.Range("AK27")
panelCrateData(12) = panelTableData(30, 1) '.Range("AK28")
panelCrateData(13) = panelTableData(31, 1) '.Range("AK29")
panelCrateData(14) = panelTableData(28, 1) '.Range("AK26")
panelCrateData(15) = panelTableData(34, 1) '.Range("AK32")
panelCrateData(16) = panelTableData(33, 1) '.Range("AK31")
panelCrateData(17) = panelTableData(35, 1) '.Range("AK33")
panelCrateData(18) = panelTableData(36, 1) '.Range("AK34")
panelCrateData(19) = panelTableData(37, 1) '.Range("AK35")
panelCrateData(20) = panelTableData(38, 1) '.Range("AK36")
panelCrateData(21) = panelTableData(39, 1) '.Range("AK37")
panelCrateData(22) = .Range("AU19")
'Holdback Info
panelCrateData(23) = .Range("AU12")
panelCrateData(24) = .Range("AU14")
'Additional Saddles
crateSht.Range(crateSht.Cells(writeRow, infoTableCol), crateSht.Cells(writeRow, infoTableCol + 24)) = panelCrateData ' "M" & writeRow & ":AK" & writeRow) = panelCrateData
End With
For writeRow = 2 To 500
If Len(crateSht.Range("A" & writeRow).value) = 0 Then ' Or crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value Then
'If continueToEnd Then
Exit For
End If
Next
Dim lastRow As Integer
lastRow = writeRow - 1
Dim totSqft As Double
totSqft = WorksheetFunction.Sum(crateSht.Range(crateSht.Cells(2, infoTableCol), crateSht.Cells(lastRow, infoTableCol))) '(crateSht 2:M" & lastRow))
Application.PrintCommunication = False
With crateSht
.PageSetup.PrintArea = "$A$1:$H$" & CStr(lastRow)
.PageSetup.PrintTitleRows = "$1:$1"
If lastRow = 2 Then .PageSetup.CenterHeader = "#" & MoveToSht.Range("AK3").value
.PageSetup.RightFooter = CStr(lastRow - 1) & " PANELS" & vbLf & "TOUCH UP KIT" & vbLf & "INTERCONNECTORS" _
& vbLf & "GLOVES" & vbLf & "T-BAR CLIPS" & vbLf & "INSULATION ON PANEL"
.PageSetup.RightHeader = CStr(totSqft) & " SQFT"
End With
Application.PrintCommunication = True
With frontSht
.Cells(11, 2) = lastRow - 1
.Cells(30, 2) = totSqft
End With
MoveToWkb.SaveAs filename:=FileLocation, FileFormat:=50
MoveToWkb.Close False
Set MoveToWkb = Nothing
'**********************************************************************************'
'Add new entry to recent panels table, unless room number already exists then replace that entry with the current info=
Call AddRecentPanelData
MoveFromSht.Delete
newXL.Application.ScreenUpdating = True
newXL.Application.DisplayAlerts = True
newXL.Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic
Set MoveFromWkb = Nothing
Set MoveFromSht = Nothing
Set MoveToSht = Nothing
newXL.Workbooks.Open FileLocation ', UpdateLinks:=False ', ReadOnly:=False
Set newXL = Nothing
Else
MoveToWkb.Close SaveChanges:=False
Set MoveToWkb = Nothing
newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
MoveFromSht.Delete
Application.Calculation = xlCalculationAutomatic
Set newXL = Nothing
Set MoveFromWkb = Nothing
Set MoveFromSht = Nothing
Set MoveToSht = Nothing
End If
Exit Sub
'#########################################################################################
ErrorHandler:
Dim Msg As String
If Err.number <> 0 Or Err.number <> 20 Then
Msg = "Error # " & Str(Err.number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Call ReactiveUpdating
End Sub
So Workbook A uses this sub to create Workbook B/Instance B and save worksheets to it. The problem is, when Workbook A tries to add the 20th worksheet (sometimes 24th or 23rd but consistently in this area) there is an error in opening Workbook B in Instance B on this line (a couple scrolls up from the bottom) causing the code to break:
newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
Method 'Open' of object 'Workbooks' failed
If I click continue after this error pops up, it completes without an issue, but Workbook B in Instance B is corrupt. Also, if I click the X to close it Excel crashes, and Workbook B is corrupt/unable to open.
The strange thing is, it will always crash after the same number of worksheets are saved (between 20-23 worksheets). Even when I tried closing both workbooks and instances down completely after saving 19 times (just before the expected crash), saving the 20th worksheet still caused a crash.
This only started happening about a month ago, and it occurs on all the computers we have tested it on. We have even tested year old versions of the workbook, that certainly never had this issue, and they all have the same issue.
Please let me know if you can offer any help or need any more detail, any insight is greatly appreciated!
After a lot of work trying to change around the saving/opening process of the workbooks, I managed to figure out the issue. The workbook being saved (Workbook B) contained an ActiveX List Box control object, and after getting rid of it the issue went away. Hopefully this saves somebody the hours it took me to solve it!