Question

好的，我有一些单独的excel文件，我需要合并到一个excel文件中。我有代码来做这个并添加标题行用于排序目的。问题是如果我在导入时点击取消它会将我带到调试屏幕。如果用户点击取消，我希望它结束该功能。我已经尝试了几种不同的方法，但是继续使用我已经注释掉的IF的类型不匹配。以下是我在网上找到的代码的修改。任何正确方向的帮助将不胜感激。提前谢谢。

Sub MergeAllWorkbooks()

Call MergeFMDataSelect
Call AddHeaders

End Sub

Sub MergeFMDataSelect()

    Dim SummarySheet As Worksheet, WorkBk As Workbook
    Dim SelectedFiles() As Variant
    Dim FileName As String, FolderPath As String
    Dim NFile As Long, LastRow As Long, NRow As Long
    Dim SourceRange As Range, DestRange As Range
    Application.ScreenUpdating = False

    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    'Set SummarySheet = Worksheets("FMData")

    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Users\Desktop"

    ' Set the current directory to the the folder path.
    ChDrive FolderPath
    'ChDir FolderPath

    ' Open the file dialog box and filter on Excel files, allowing multiple files
    ' to be selected.
    SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)

    'If SelectedFiles = Cancel Then
        'MsgBox "File not selected to import. Process Terminated"
        'Exit Sub
    'End If**

    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1

    ' Loop through the list of returned file names
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        ' Set FileName to be the current workbook file name to open.
        FileName = SelectedFiles(NFile)

        ' Open the current workbook.
        Set WorkBk = Workbooks.Open(FileName)

        ' Set the cell in column A to be the file name.
        'SummarySheet.Range("A" & NRow).Value = FileName

        ' Set the source range
        LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", After:=WorkBk.Worksheets(1).Cells.Range("A1"), SearchDirection:=xlPrevious, LookIn:=xlFormulas, SearchOrder:=xlByRows).Row
        Set SourceRange = WorkBk.Worksheets(1).Range("A2:BA" & LastRow)

        ' Set the destination range to start at column a and be the same size as the source range.
        Set DestRange = SummarySheet.Range("A" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)

        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value

        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count

        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False

    Next NFile
    Application.ScreenUpdating = True

    ' Call AutoFit on the destination sheet so that all data is readable.
    ' SummarySheet.Columns.AutoFit

End Sub

Sub AddHeaders()
Dim headers() As Variant
Dim ws As Worksheet
Dim wb As Workbook

Application.ScreenUpdating = False 'turn this off for the macro to run a little faster

Set wb = ActiveWorkbook

headers() = Array("OBJECTID", "cfeedernum", "clinenum", "cpolenum", "ctaxdist", "clocation", "cregion", "copdist", "czone")

Range("A1").EntireRow.Insert
For Each ws In wb.Sheets
    With ws
    '.Rows(1).Value = "" 'This will clear out row 1
    For i = LBound(headers()) To UBound(headers())
        .Cells(1, 1 + i).Value = headers(i)
    Next i
    .Rows(1).Font.Bold = True
    End With
Next ws

Application.ScreenUpdating = True 'turn it back on

MsgBox ("Done!")

End Sub

Answer 1

声明SelectedFiles As Variant并测试If (VarType(SelectedFiles) = vbBoolean) Then以检测取消操作。

GetOpenFilename VBA的错误或取消处理程序

1 个答案: