Question

我已经从32位升级到64位，并且无法合并和排列文件夹中的文件的宏不再起作用了，不是VBA用户，因此陷入了困境，不胜感激帮助marco工作？

Option Explicit

 '32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long

Public Type BrowseInfo
    hOwner As Long
    pIDLRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Function GetDirectory(Optional msg) As String
    On Error Resume Next
    Dim bInfo As BrowseInfo
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

     'Root folder = Desktop
    bInfo.pIDLRoot = 0&

     'Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Please select the folder of the excel files to copy."
    Else
        bInfo.lpszTitle = msg
    End If

     'Type of directory to return
    bInfo.ulFlags = &H1

     'Display the dialog
    x = SHBrowseForFolder(bInfo)

     'Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Sub CombineFiles()
    Dim path            As String
    Dim FileName        As String
    Dim LastCell        As Range
    Dim Wkb             As Workbook
    Dim ws              As Worksheet
    Dim ThisWB          As String

    Application.DisplayAlerts = False


    ThisWB = ThisWorkbook.Name
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = GetDirectory
    FileName = Dir(path & "\*.xlsx", vbNormal)
    Do Until FileName = ""
        If FileName <> ThisWB Then
            Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
            For Each ws In Wkb.Worksheets
                If ws.Visible = xlSheetHidden Then
                Else
                    ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                End If
            Next ws
            Wkb.Close False
        End If
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing

    Call Sort_Tabs

    Call Hide_create_tab

    Call Select_all_sheets

    Application.Dialogs(xlDialogSaveAs).Show "Enter MCR file name"


    Application.DisplayAlerts = True

End Sub


Sub Sort_Tabs()
     'declare our variables
    Dim i, j As Integer
    Dim iNumSheets As Integer
     'find the number of sheets to work with
    iNumSheets = ActiveWorkbook.Sheets.Count
     'turn off screen updating to prevent screen flicker
    Application.ScreenUpdating = False
     'work through our number of sheets
    For i = 1 To iNumSheets - 1
        For j = i + 1 To iNumSheets
             'check the name of the sheet regardless of case
            If UCase(Sheets(i).Name) > UCase(Sheets(j).Name) Then
                 'set where to move the sheet to
                Sheets(j).Move before:=Sheets(i)
            End If
             'do next sheet
        Next j
    Next i
     'let the screen update
    Application.ScreenUpdating = True
End Sub

Sub Hide_create_tab()

Sheets("Create MCR").Select
ActiveSheet.Visible = False

End Sub

Sub Select_all_sheets()

Dim ws As Worksheet
For Each ws In Sheets
    If ws.Visible Then ws.Select (False)
Next
End Sub

Answer 1

看看这个页面： https://jkp-ads.com/Articles/apideclarations.asp

注意：请确保您邮件中的所有代码均已标记为这样，以便我们轻松阅读代码。

VBA /宏从32位升级到64位

1 个答案: