Function GetFolder() As String
'文件及文件夹路径函数
    Dim dlgOpen As FileDialog
    Dim i As Long, j As Long
    Set dlgOpen = Application.FileDialog(msoFileDialogOpen)
    With dlgOpen
        .AllowMultiSelect = True
        .Show
    End With
    i = dlgOpen.SelectedItems.Count
    If i > 0 Then
        GetFolder = ""
        For j = 2 To i
            GetFolder = GetFolder & dlgOpen.SelectedItems(j) & ";"
        Next
        j = 1
        GetFolder = GetFolder & dlgOpen.SelectedItems(j)
    Else
        GetFolder = dlgOpen.InitialFileName '或GetFolder = CurDir() & "\"
    End If
    Set dlgOpen = Nothing
End Function

 

方法一:

Sub 导入数据()

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim strname As String
Dim shtname As String
On Error GoTo 导入_Err
    ActiveSheet.Unprotect                                                   '解锁
    shtname = Range("Q1") & "月"                                            '获取sheet名称
    strname = GetFolder                                                     '获取sheet文件名称
    If InStr(strname, Range("B3")) > 0 Then
        xlApp.Application.Visible = True
        Set xlBook = xlApp.Workbooks.Open(strname)
        Set xlsheet = xlBook.Worksheets(shtname)
        xlsheet.Activate
        xlsheet.Range("C9:Q66").Select
        xlsheet.Range("C9:Q66").Copy                                        '拷贝数据
        Range("C9:Q66").Select
        ActiveSheet.Paste                                                   '粘贴数据
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True '锁定
        Range("C9").Select
        xlApp.Quit
        Set xlApp = Nothing
        Set xlBook = Nothing
        Set xlsheet = Nothing
    Else
        MsgBox "打开文件错误！请打开" & Range("B3") & "表格文件。"
    End If
   
导入_Exit:
            xlApp.Quit
            Exit Sub
导入_Err:
            MsgBox "错误！请退出！"
            Resume 导入_Exit
End Sub

方法二: 

Sub 导入2()
Dim strname As String
Dim shtname As String
On Error GoTo 导入_Err
    ActiveSheet.Unprotect                                                                '解锁
    shtname = Range("Q1") & "月"
    strname = GetFolder
    If InStr(strname, Range("B3")) > 0 Then
        Application.Workbooks.Open strname                                               '打开文件
        Windows("收发存汇总月报.xls").Activate
        Windows(Range("B3") & ".xls").Activate
        Sheets(shtname).Select
        Range("C9:Q66").Select
        Selection.Copy
        Windows("收发存汇总月报.xls").Activate
        Range("C9:Q66").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False                                                    '选择性粘贴
         ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True          '锁定
        Range("C9").Select
        Windows(Range("B3") & ".xls").Close
    Else
        MsgBox "打开文件错误！请打开" & Range("B3") & "表格文件。"
    End If
导入_Exit:
            Exit Sub
导入_Err:
            MsgBox "错误！请退出！"
            Resume 导入_Exit
End Sub