| 网站首页 | 业界新闻 | 小组 | 交易 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
共有 1422 人关注过本帖
标题:请高手帮忙看下代码的问题,怎么实现将多个工作簿中的数据复制粘贴到当前工 ...
取消只看楼主 加入收藏
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
结帖率:66.67%
  已结贴   问题点数:10  回复次数:6   
请高手帮忙看下代码的问题,怎么实现将多个工作簿中的数据复制粘贴到当前工作表中
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
运行时错误,类型不匹配

[此贴子已经被作者于2017-12-14 21:41编辑过]

附件: 您没有浏览附件的权限,请 登录注册
搜索更多相关主题的帖子: Application False With End Selection 
【推荐】大型监控、工控、组态VC++./C#源码组件库2019下载!
【推荐】超50万数控、建模仿真、电力VC++/.NET图形源码库下载!
【推荐】专业CAD\GIS\业务流程VC++/C#可视化图形软件源码库下载!
2017-12-14 21:39
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
  得分:0 
回复 2楼 wds1
代码貌似还是有问题,还是不能实现将打开的工作簿内容复制粘贴到当前表,然后再另存为一个新的工作簿,.........一直循环完当前工作表路径下的所有文件
2017-12-15 20:10
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
  得分:0 
回复 4楼 wds1
另存为一个新的工作簿,在当前工作簿所在文件路径下
附件: 您没有浏览附件的权限,请 登录注册
2017-12-16 21:14
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
  得分:0 
回复 4楼 wds1
谢谢&#128591;
2017-12-16 21:16
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
  得分:0 
回复 7楼 wds1
我测试了下,代码还是有缺陷
2017-12-17 18:18
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
  得分:0 
回复 7楼 wds1
这个是不是不容易实现啊
2017-12-17 18:19
jackh
Rank: 1
等 级:新手上路
帖 子:26
专家分:0
注 册:2017-11-9
  得分:0 
回复 10楼 wds1
好的,谢谢
2017-12-17 23:53
快速回复:请高手帮忙看下代码的问题,怎么实现将多个工作簿中的数据复制粘贴到当 ...
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.050633 second(s), 9 queries.
Copyright©2004-2019, BCCN.NET, All Rights Reserved