关于用VBA对多工作薄进行合并时的选择性粘贴问题

京杉钰666

请教各位大神，
在网上搜到一个多工作薄中工作表合并的VBA代码（感谢这位不知名的大神），但使用中有一些问题，由于我在工作中表中工式较多，有些是引其它表的，用这个代码运行后出现些问题，我想对代码进行优化，合并时想用选择性粘贴数值，不知道改代码中哪个地方，在网上搜索多时也不得要领，现求助各位大神，在此先谢过了！  代码如下：
Option Explicit

Sub MyAssemble()
Dim WbName As Variant, StartRow As Integer, i As Integer, SubWb As Object, LastRow As Long, LastCol As Long, InsertR As Long
Dim ShowWbName As Variant, AllWbName As String, WbNum As Integer, DataSheet As Integer
WbName = Application.GetOpenFilename(filefilter:="Excel,*.xls;*.xlsx", Title:="需要合并的工作簿——可以多选", MultiSelect:=True)
If TypeName(WbName) = "Boolean" Then Exit Sub

WbNum = UBound(WbName) - LBound(WbName) + 1

DataSheet = Val(InputBox("抽取第几个sheet的数据？" & vbCrLf & vbCrLf & "输入编号：", , 1))
If DataSheet <= 0 Then Exit Sub
StartRow = Val(InputBox("从第几行开始抽取数据？请考虑是否有表头。"))
If StartRow <= 0 Then Exit Sub

AllWbName = "即将合并下列 " & WbNum & " 个工作簿，第 " & DataSheet & " 个sheet，从第 " & StartRow & " 行起的数据" & vbCrLf
For i = LBound(WbName) To UBound(WbName)
    ShowWbName = Split(WbName(i), "\")
    AllWbName = AllWbName & vbCrLf & ShowWbName(UBound(ShowWbName))
Next i
If MsgBox(AllWbName, vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
For i = LBound(WbName) To UBound(WbName)
    InsertR = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row
    If LCase(WbName(i)) <> LCase(ThisWorkbook.FullName) Then
        Set SubWb = GetObject(WbName(i))
        If SubWb.Sheets.Count >= DataSheet Then
            With SubWb.Sheets(DataSheet)
                LastRow = .UsedRange.Rows.Count + .UsedRange.Row - 1
                LastCol = .UsedRange.Columns.Count + .UsedRange.Column - 1
                Range(.Cells(StartRow, 1), .Cells(LastRow, LastCol)).Copy Destination:=ActiveSheet.Cells(InsertR, 1)
            End With
        Else
            MsgBox "以下工作簿中不存在第 " & DataSheet & " 个sheet，该工作簿将被跳过。" & vbCrLf & vbCrLf & WbName(i)
        End If
        SubWb.Close False
        Set SubWb = Nothing
    End If
Next i
Application.ScreenUpdating = True
End Sub

京杉钰666

今天又捣鼓了好一会儿还是修改不成功啊，我已知道应该改  Range(.Cells(StartRow, 1), .Cells(LastRow, LastCol)).Copy Destination:=ActiveSheet.Cells(InsertR, 1) 这一行，但尝试几次都不行啊，有没有哪位大神知道怎么改的，还请赐教。

刀羊

京杉钰666 发表于 2018-10-12 16:43
今天又捣鼓了好一会儿还是修改不成功啊，我已知道应该改  Range(.Cells(StartRow, 1), .Cells(LastRow, Las ...

先猜一下吧：

试试把        Range(.Cells(StartRow, 1), .Cells(LastRow, LastCol)).Copy Destination:=ActiveSheet.Cells(InsertR, 1)
改为          .Range(.Cells(StartRow, 1), .Cells(LastRow, LastCol)).Copy Destination:=ActiveSheet.Cells(InsertR, 1)

京杉钰666

加了一个.之后运行，没有成功哦，合并的仍然不是选择性粘贴数值，不过还是要感谢大神的指点！