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 Application对象传递到子例程中，但未完全使用它，您也没有明确引用这些库：

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

运行您的代码并首先修复所有这些，然后测试＆amp;提供有关问题的确切症状的更多反馈。

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

1 个答案: