Question

我有一个模板化的Excel文件，该文件将用于将单元格值保存到SQL。将有大约一千个具有不同名称的名称执行相同的功能。因此，我想将模板中的代码删除到另一个文件中，以便在需要时进行全局更改。

用户从文件A开始工作，然后单击保存按钮，执行以下代码以运行文件B中包含的宏。

Sub Save_Inspection()
   Dim wb As Workbook
   On Error Resume Next
   Set wb = Workbooks("SaveInspectionData.xlsm")
   On Error GoTo 0
   If wb Is Nothing Then Set wb = Workbooks.Open("\\ABSOLUTE2\Cloud9\Files\XDomainDocs\SaveInspectionData.xlsm")
   Dim FileName As String
   FileName = ThisWorkbook.Name
   Run "SaveInspectionData.xlsm!sheet1.Save_Inspection", FileName
   wb.Close False
   Set wb = Nothing
End Sub

下面是用于保存文件B上的数据的代码。注意-这时已提到有多少行或列，因此我在循环遍历以创建SQL查询以及行，列等的数量。一切正常。

我的问题是当我尝试关闭工作簿时。我希望它们都关闭，无论我尝试什么，都只能关闭两者之一。下面的代码反映了最简单的close方法，但是我尝试了其他几种技术。

经过一些搜索，这可能与我使用“ With”语句引用文件A有关，但我不确定。

谢谢！

Sub Save_Inspection(FileName As String)
On Error GoTo errH

Dim strUserDomain As String
Dim cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String

Dim InspectionId As Integer 'Will use this Id to associate all results to this Inspection Instance

Dim Query As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset

'Find proper connection string
strUserDomain = Environ$("UserDomain")
`If strUserDomain = "TLCWSBIMH" Then
    Server_Name = "bobby"
    Database_Name = "Inspection"
    User_ID = "xxx"
    Password = "xxx"
ElseIf strUserDomain = "TLCWSBEFS" Then
    Server_Name = "EFSNextGen"
    Database_Name = "Inspection"
    User_ID = "xxx"
    Password = "xxx"
ElseIf strUserDomain = "TLCWSBTC" Then
    Server_Name = "AS-Quality"
    Database_Name = "Inspection"
    User_ID = "xxx"
    Password = "xxx"
Else
    'Something must be wrong
    Exit Sub
End If

Workbooks(FileName).Activate
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks(FileName)
Set ws = wb.Sheets(1)

'Let's Save this stuff!
Dim DateInspected, PartNumber, LotNumber, Revision As String
'Set values
With ws
    'DateInspected = .Range("Q5").Value
    PartNumber = .Range("K4").Value
    LotNumber = .Range("G3").Value
    Revision = .Range("Q4").Value
End With
Query = "INSERT INTO InspectionCatalog (DateInspected, PartNumber, LotNumber, Revision) VALUES (GETDATE(), '" & PartNumber & "', '" & LotNumber & "', '" & Revision & "')"

Set cn = New ADODB.Connection
cn.Open "Provider=SQLOLEDB;Server=" & Server_Name & ";Initial Catalog=" & Database_Name & ";Uid=" & User_ID & ";Pwd=" & Password & ";"

cn.Execute (Query)
rs.Open "SELECT @@identity AS InspectionId", cn
InspectionId = rs.Fields("InspectionId")
'MsgBox (InspectionId)'For testing

'Loop through all cells on sheet and save results
Call LoopThroughResults(InspectionId, FileName, strUserDomain)

Exit Sub
    errH:
    MsgBox Err.Description
End Sub

Sub LoopThroughResults(InspectionId As Integer, FileName As String, strUserDomain As String)
On Error GoTo errH

'Declare Variables
Dim RowCount As Integer
Dim CollCount As Integer
Dim Coll_Count As Integer

Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks(FileName)
Set ws = wb.Sheets(1)

'Find the number of rows in the sheet based on a value in Col U
With ws
    RowCount = .Cells(.Rows.Count, "G").End(xlUp).Row
    'MsgBox RowCount
End With

'Go through each row and find the number of columns that are filled
'Set CollCount to the longest row - ignoring 1-9 these are header fields
For i = 10 To RowCount
With ws
    Coll_Count = .Cells(i, .Columns.Count).End(xlToLeft).Column
    If Coll_Count > CollCount Then
    'Find the length of the longest row
    CollCount = Coll_Count
    End If
    'MsgBox "Row " & i & " Has " & Coll_Count & " Columns!"
End With
Next i
'MsgBox "The Row with the Most data has " & CollCount & " Columns!"

'Save Col Count to be used for retrieving the data later
Dim Query As String
Query = "UPDATE InspectionCatalog SET CollCount='" & CollCount & "', [RowCount]='" & RowCount & "' WHERE InspectionId='" & InspectionId & "' "
Call SaveResults(Query, strUserDomain)

Dim QueryStart As String
Dim QueryEnd As String

'Loop through each row starting at 2 (Not 10, this time we want to capture all data
For i = 2 To RowCount
'Reset Query String befor hitting next row
QueryStart = "INSERT INTO InspectionResults ("
QueryEnd = " VALUES ("
'Loop through each column to create insert query
    For n = 1 To CollCount
            QueryStart = QueryStart & "Col" & n & ","
            QueryEnd = QueryEnd & "N'" & Workbooks(FileName).Worksheets("Inspection Report").Cells(i, n).Value & "',"
    Next n
    QueryStart = QueryStart & "InspectionId)"
    QueryEnd = QueryEnd & "'" & InspectionId & "');"
    'MsgBox QueryStart & QueryEnd
    Call SaveResults(QueryStart & QueryEnd, strUserDomain)
Next i

MsgBox "Inspection Data Has Been Saved"
Call CloseWorkBooks(FileName)

Exit Sub
errH:
    MsgBox Err.Description
End Sub

Sub SaveResults(Query As String, strUserDomain As String)
On Error GoTo errH
Dim cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset

'Find proper connection string
strUserDomain = Environ$("UserDomain")

If strUserDomain = "TLCWSBIMH" Then
    Server_Name = "bobby"
    Database_Name = "Inspection"
    User_ID = "xxx"
    Password = "xxx"
ElseIf strUserDomain = "TLCWSBEFS" Then
    Server_Name = "EFSNextGen"
    Database_Name = "Inspection"
    User_ID = "xxx"
    Password = "xxx"
ElseIf strUserDomain = "TLCWSBTC" Then
    Server_Name = "AS-Quality"
    Database_Name = "Inspection"
    User_ID = "xxx"
    Password = "xxx"
Else
    'Something must be wrong
    Exit Sub
End If

Set cn = New ADODB.Connection
cn.Open "Provider=SQLOLEDB;Server=" & Server_Name & ";Initial Catalog=" & Database_Name & ";Uid=" & User_ID & ";Pwd=" & Password & ";"
cn.Execute (Query)
Exit Sub
errH:
    MsgBox Err.Description
End Sub

Sub CloseWorkBooks(FileName As String)
    Workbooks(FileName).Close SaveChanges:=False
    Workbooks("SaveInspectionData.xlsm").Close SaveChanges:=False
    Exit Sub
End Sub

Answer 1

请注意，Application.Run在与当前工作簿相同的“环境”中执行代码。基本上，执行Application.Run的工作簿就是运行代码的工作簿，新的工作簿将链接到同一会话。这将导致您正在观察的特殊情况。关闭由“运行”执行的工作簿将使该工作簿中的任何宏（子，函数，对象，工作表）超出范围，并且任何运行的代码将停止在该工作簿中运行。此外，随着笔记本的关闭，代码不会在执行的工作簿中“完成”，因此我们将不会返回到原始工作簿，从而有效地终止了原始笔记本中的所有执行。

此外，由于代码将尝试返回到原始工作簿，以完成原始正在运行的子项（此处为原始工作簿中的Save_Inspection（）），因此将两个工作簿链接到同一会话（或环境），从而关闭该工作簿将首先暂停运行的原始代码（由于现在已关闭工作簿，因此实际上无法进入Save_Inspection的下一行），这也将结束会话。

因此无法直接关闭由Application.Run打开和执行的工作簿中的所有工作簿。可以解决方法。最简单的方法是关闭原始工作簿中的所有工作簿（在application.run之后放置wb.close false: Thisworkbook.close false）。或者在第二个工作簿中创建一个运行“ Application.Ontime”并将其文件名保存到供“ ontime”运行的函数使用的单元格的子程序，应确保在第二个笔记本中运行代码时不会链接两个会话。但是我不太确定实际上是这样。

下面是原始笔记本中的代码。如果原始工作簿完成了，则应最后关闭工作簿。

Sub Save_Inspection()
   Dim wb As Workbook
   On Error Resume Next
   Set wb = Workbooks("SaveInspectionData.xlsm")
   On Error GoTo 0
   If wb Is Nothing Then
    Set wb = Workbooks.Open(ThisWorkbook.Path & "SaveInspectionData.xlsm")
   End If
   Dim FileName As String
   FileName = ThisWorkbook.Name
   Run "SaveInspectionData.xlsm!sheet1.CloseBooks", FileName
   wb.Close False
   ThisWorkbook.Close False
   Set wb = Nothing
End Sub

Answer 2

在Oliver上面，他很好地解释了为什么我的程序无法正常运行。为了解决此问题，我删除了关闭工作簿的调用，工作簿A中的代码自行处理。我确实对上述代码做了一些小改动，以根据打开的实例数量来处理关闭Excel或工作簿。

Sub Save_Inspection()
Dim wb As Workbook
Dim wb2 As Workbook
On Error Resume Next
Set wb = Workbooks("SaveInspectionData.xlsm")
On Error GoTo 0
If wb Is Nothing Then Set wb = Workbooks.Open("\\ABSOLUTE2\Cloud9\Files\XDomainDocs\SaveInspectionData.xlsm")
Dim FileName As String
FileName = ThisWorkbook.Name
Run "SaveInspectionData.xlsm!sheet1.Save_Inspection", FileName
If Application.Workbooks.Count > 2 Then
    wb.Close False
    ThisWorkbook.Close False
    Set wb = Nothing
Else
    Application.Quit
End If
End Sub

Excel在另一个工作簿中运行宏，第一个参考数据，然后将它们都关闭。只有一个会关闭

2 个答案: