| 网站首页 | 业界新闻 | 群组 | 人才 | 下载频道 | 博客 | 代码贴 | 编程论坛
共有 527 人关注过本帖
标题:请高手帮忙看下代码的问题,怎么实现将多个工作簿中的数据复制粘贴到当前工 ...
只看楼主 收藏
jackh
Rank: 1
等 级:新手上路
帖 子:15
专家分:0
注 册:2017-11-9
结帖率:60%
  已结贴   问题点数:10  回复次数:10   
请高手帮忙看下代码的问题,怎么实现将多个工作簿中的数据复制粘贴到当前工作表中
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编辑过]

附件: 您没有浏览附件的权限,请 登录注册
2017-12-14 21:39
wds1
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:14
帖 子:138
专家分:703
注 册:2016-3-10
  得分:10 
你这个程序是execl的vba程序,出错的是格式设置部分,我把格式部分去掉了

实现功能:把同一目录的*.xlsx复制到打开的B3开始的位置

【这个实现的功能是把没打开的保存到当前打开的表中,没做保存】

Sub 批量创建新表()
    Application.ScreenUpdating = False
    Dim FileName As String
    Dim Workbook As Workbook
    Dim rg As Range
    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
      temp = "B" & Trim(Str(r))'新增的控制下一文件在最后面复制
     ThisWorkbook.Sheets(1).Range(temp).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False  
      .Close False
    End With
    FileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub



[此贴子已经被作者于2017-12-15 23:36编辑过]

2017-12-15 10:29
jackh
Rank: 1
等 级:新手上路
帖 子:15
专家分:0
注 册:2017-11-9
  得分:0 
回复 2楼 wds1
代码貌似还是有问题,还是不能实现将打开的工作簿内容复制粘贴到当前表,然后再另存为一个新的工作簿,.........一直循环完当前工作表路径下的所有文件
2017-12-15 20:10
wds1
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:14
帖 子:138
专家分:703
注 册:2016-3-10
  得分:0 
你的意思是把每一个龙凤山村X组表单独粘贴到身份证件信息统计表,之后另存。
我理解为把所有表复制到身份证件信息统计表。

如果是每一个龙凤山村X组表粘贴到身份证件信息统计表,再保存,那么保存格式是什么,粘贴到哪个sheet。
最好有示例。

2017-12-16 00:06
jackh
Rank: 1
等 级:新手上路
帖 子:15
专家分:0
注 册:2017-11-9
  得分:0 
回复 4楼 wds1
另存为一个新的工作簿,在当前工作簿所在文件路径下
附件: 您没有浏览附件的权限,请 登录注册
2017-12-16 21:14
jackh
Rank: 1
等 级:新手上路
帖 子:15
专家分:0
注 册:2017-11-9
  得分:0 
回复 4楼 wds1
谢谢&#128591;
2017-12-16 21:16
wds1
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:14
帖 子:138
专家分:703
注 册:2016-3-10
  得分:0 
把原来的表重新另存,没做格式设置
Sub 批量创建新表()
    Application.ScreenUpdating = False
    Dim FileName As String
    Dim Workbook As Workbook
    Dim rg As Range
    Dim r As Integer
    Dim n As Integer
    n = 1'文件计数用
    Application.DisplayAlerts = False'屏蔽提示
    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
      .Close False
    End With
  
      N_PATH = ThisWorkbook.Path '定义保存路径,可自己定义保存位置
      N_NAME = N_PATH & "\导出文件名称" & Trim(Str(n)) & ".xls" '定义保存文件路径及文件名
      ActiveWorkbook.SaveAs N_NAME
      n = n + 1
    FileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
2017-12-16 23:30
jackh
Rank: 1
等 级:新手上路
帖 子:15
专家分:0
注 册:2017-11-9
  得分:0 
回复 7楼 wds1
我测试了下,代码还是有缺陷
2017-12-17 18:18
jackh
Rank: 1
等 级:新手上路
帖 子:15
专家分:0
注 册:2017-11-9
  得分:0 
回复 7楼 wds1
这个是不是不容易实现啊
2017-12-17 18:19
wds1
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:14
帖 子:138
专家分:703
注 册:2016-3-10
  得分:0 
不是不容易实现。
想实现什么样的目标,必须描述清楚,这样才能达到目的。
另外,怎么达到自己满意,还得自己动脑。

我看你的表格,没有什么复杂数据,用不用VBA都可以。
如果是想自动化,那么vba宏处理不如,文件方式好;
如果想锻炼开发,那么多查查资料,多调试,是最好的方法。

另外我给你写的2次,1次是把当前目录到*.xlsx内容加表头都复制到身份证表;另一个是把当前目录到*.xlsx内容加表头单个复制到每个导出文件.xls。
文件边框,格式,居中,字体等,好设置,你录一下宏,就知道。



2017-12-17 20:51







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

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