需要一些关于如何流线的建议ACCESS/EXCEL VBA

Question

我写了这个Access/VBA程序。它的工作原理，但只有当我没有运行其他应用程序或少数用户在数据库中。我需要一些简化代码的想法。所以它不是那么系统密集的。该程序基本上允许用户选择一个文件夹，然后将该文件夹中的所有工作表组合到一个Excel文档中。我目前的想法只是告诉用户在试图运行程序时关闭所有的excel文件。请帮助：

Sub Excel_open() 

Dim myXL As Excel.Application 
Dim myXLS As Excel.Workbook 
Const errExcelNotRunning = 429 

On Error GoTo HandleIt 
    Set myXL = GetObject(, "Excel.application") 
    myXL.Visible = True 
    Set myXLS = myXL.Workbooks.Add 

    Call CombineWorkbooks(myXL) 

HandleIt: 

If Err.Number = errExcelNotRunning Then 
    Set myXL = CreateObject("Excel.Application") 
    Err.Clear 
    Resume Next 
End If 

End Sub 
Sub CombineWorkbooks(myXL) 


'Macro that combines the files into one folder 
    myXL.AskToUpdateLinks = False 
    myXL.DisplayAlerts = False 

    Dim CurFile As String, dirloc As String, strNamesheet As String 
    Dim DestWB As Workbook 
    Dim ws As Object ' allows for diffrent sheet types 

    'Add select the director function 

    dirloc = GetFolderName & "\" 'location of files not working want to select the file only 
    CurFile = Dir(dirloc & "*.xls*") 

    myXL.ScreenUpdating = False 
    myXL.EnableEvents = False 

    Set DestWB = Workbooks.Add(xlWorksheet) 

    Do While CurFile <> vbNullString 
     Dim OrigWB As Workbook 
     Set OrigWB = Workbooks.Open(FileName:=dirloc & CurFile, ReadOnly:=True) 

     'need to change a name active name is not doing it 

     CurFile = Left(CurFile, 4) ' This is no longer 29 

     'CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29) 

     For Each ws In OrigWB.Sheets 
      ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count) 

      ' Use the name to give the sheet a name 

      strNamesheet = Left((ws.Name), 25) & ";" 

      If OrigWB.Sheets.Count > 1 Then 
       DestWB.Sheets(DestWB.Sheets.Count).Name = strNamesheet & CurFile ' & ws.Index 
      Else 
       DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile 
      End If 
     Next 

     OrigWB.Close SaveChanges:=False 
     CurFile = Dir 

    Loop 

    myXL.DisplayAlerts = False 
    DestWB.Sheets(1).Delete 
    myXL.DisplayAlerts = True 


    myXL.ScreenUpdating = True 
    myXL.EnableEvents = True 

    Set DestWB = Nothing 

    Call Delete_empty_Sheets(myXL) 
    Call Sort_Active_Book 

    MsgBox "Done" 

    'Call Xcombine_the_Matching 

End Sub 
Sub Delete_empty_Sheets(myXL) 
'goes through all sheets and deletes 

Reset_the_search: 

For Each wsElement In Worksheets 
    If wsElement.Range("A2") = "" And wsElement.Range("B2") = "" Then 
     myXL.DisplayAlerts = False 
     wsElement.Delete 
     GoTo Reset_the_search 
     myXL.DisplayAlerts = True 

    End If 
Next wsElement 

End Sub 



Sub Xcombine_the_Matching() 
    'I think I can make the order work 
    'change and transpose the array 
    Dim varStart As Variant 
    Dim wsCompare As Worksheet 

    Dim strMatch As String 


    'Dim varCompare As Variant 

    Dim strVareince As String 
    Dim strCurrentName As String 

    'you need to build a loop to solve this problem 

    For Each wsCompare In Worksheets 

     strVareince = Add_Array(Application.Transpose(wsCompare.Range("A1:Z1"))) 

     For Each wsNompare In Worksheets 

      If wsNompare.Name <> strCurrentName Then 
       If strVareince = Add_Array(Application.Transpose(wsNompare.Range("A1:Z1"))) Then 
        MsgBox ("Matched with worksheet " & wsNompare.Name) 
       End If 

      End If 

     Next 

    Next 

End Sub 

Function array_to_string(x) As String 
    For Z = 1 To 26 
     array_to_string = array_to_string & x(Z, 1) & ";" 
    Next Z 

End Function 

Function GetFolderName(Optional OpenAt As String) As String 
    'Allows you to select the folder director that you want to combine 
    Dim lCount As Long 

    GetFolderName = vbNullString 

    With Application.FileDialog(msoFileDialogFolderPicker) 
     .InitialFileName = OpenAt 
     .Show 
     For lCount = 1 To .SelectedItems.Count 
      GetFolderName = .SelectedItems(lCount) 
     Next lCount 
    End With 
End Function 

Function Add_Array(x) As String 
    'turns an excel document 
    For d = 1 To UBound(x) 
     Add_Array = Add_Array & x(d, 1) 
    Next d 

End Function 

Sub Read_data() 

'this the 

End Sub 

Sub Sort_Active_Book() 
Dim i As Integer 
Dim j As Integer 
Dim iAnswer As VbMsgBoxResult 
' 
' Prompt the user as which direction they wish to 
' sort the worksheets. 
' 
    iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _ 
    & "Clicking No will sort in Descending Order", _ 
    vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets") 
    For i = 1 To Sheets.Count 
     For j = 1 To Sheets.Count - 1 
' 
' If the answer is Yes, then sort in ascending order. 
' 
     If iAnswer = vbYes Then 
      If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then 
       Sheets(j).Move After:=Sheets(j + 1) 
      End If 
' 
' If the answer is No, then sort in descending order. 
' 
     ElseIf iAnswer = vbNo Then 
      If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then 
       Sheets(j).Move After:=Sheets(j + 1) 
      End If 
     End If 
     Next j 
    Next i 
End Sub 

Answer 1

你传入您的Excel应用程序对象到您的子程序，但不是充分利用它，你也不是明确的引用库：通过您的代码

Sub CombineWorkbooks(myXL) 
    Dim DestWB As Excel.Workbook ' <<< 
    Set DestWB = myXL.Workbooks.Add(xlWorksheet) ' <<< 
End Sub 

运行和解决所有的这些首先，然后测试&提供更多关于问题确切症状的反馈。