请高手帮忙看下代码的问题，怎么实现将多个工作簿中的数据复制粘贴到当前工作表中
Sub 批量创建新表()Application.ScreenUpdating = False
Dim FileName As String
Dim Workbook As Workbook
Dim r As Integer
FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While FileName <> ""
Set Workbook = Application.Workbooks.Open(ThisWorkbook.Path & "\" & FileName)
With Workbook
.Sheets(1).UsedRange.Copy
r = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 2
ThisWorkbook.Sheets(1).Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows(3).Resize(r + 1, 1).EntireRow.Select
Selection.RowHeight = 20
.Close False
End With
Range("B3").Resize(r - 2, 5).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ThisWorkbook.SaveAs FileName:="C:\Users\HGH\Desktop & " \ " & FileName", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
FileName = Dir
Loop
Application.ScreenUpdating = True
End Sub
ThisWorkbook.SaveAs FileName:="C:\Users\HGH\Desktop & " \ " & FileName", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
运行时错误，类型不匹配
龙凤山村.rar
(79.43 KB)
[此贴子已经被作者于2017-12-14 21:41编辑过]
好的，谢谢