代码之家 › 专栏 › 技术社区 › SoundWaves

Excel在另一个工作簿中运行宏,首先引用数据,然后关闭两者。只有一个会关闭

vba excel

SoundWaves · 技术社区 · 6 年前

我有一个模板化的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

2 回复 | 直到 6 年前

Oliver 6 年前

注意 Application.Run 在与当前工作簿相同的“环境”中执行代码。基本上是正在执行的工作簿 应用程序运行 是运行代码的,新工作簿将链接到同一会话。这将导致你观察到的特殊情况。关闭由“运行”执行的工作簿将使此工作簿中的任何宏(子、函数、对象、工作表)超出范围,并且任何代码运行都将停止在此工作簿中运行。此外,由于笔记本已关闭,代码在执行的工作簿中不会“完成”,因此我们不会返回到原始工作簿,从而有效地停止了原始笔记本中的任何执行。

另外,由于代码将尝试返回到原始工作簿,为了完成原始运行的Sub(在原始工作簿中的此处save_inspection()),两个工作簿将链接到同一会话(或环境),因此首先关闭此工作簿将停止原始代码的运行(转到save_inspection中的下一行将变为eff)。由于工作簿现在已关闭,因此这是完全不可能的),而且这也将结束会话。

因此,关闭由打开和执行的工作簿中的所有工作簿 应用程序运行 不能直接进行。解决办法可以做到。最简单的方法是关闭原始工作簿中的所有工作簿(放置 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

SoundWaves 6 年前

上面的奥利弗很好地解释了为什么我的程序不能正常工作。为了解决这个问题,我删除了关闭工作簿的调用,工作簿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