VBA学习之复制粘贴表

2019/9/30

1 建立测试文件夹

每张表的内容如下：

在文件夹里建立5个相同内容的副本：

2 百度网上代码进行试用

代码1（原代码链接）：

Sub MoveSheets()'在下面Array中列出所有需要复制的工作表的名称
'换行符为：空格+_Worksheets(Array("C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\test.xlsx",x_"C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\test - 副本.xlsx", "C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\test - 副本(2).xlsx",  _"C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\test - 副本(3).xlsx", _"C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\test - 副本(4).xlsx",  _"C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\test - 副本(5).xlsx")).CopySet wbNew = ActiveWorkbookWith wbNewActiveWorkbook.SaveAs Filename:="C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\" & "合并.xlsx".CloseEnd WithEnd Sub

出现错误

时间：2019/10/5
发现自己对上面代码中的工作表错理解为工作簿

Sub MoveSheets()'在下面Array中列出所有需要复制的工作表的名称
'换行符为：空格+_Worksheets(Array("Sheet1", "Sheet2")).CopySet wbNew = ActiveWorkbookWith wbNewActiveWorkbook.SaveAs Filename:="C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\" & "合并.xlsx".CloseEnd WithEnd Sub

上面这段代码的实际作用：选择自己想要的sheet(工作表)复制粘贴到一个新的工作簿

学习目标1

将一个文件夹中的所有工作簿复制粘贴到一个新的工作簿中

学习链接1
学习链接2

成功！！！
重复上面步骤

Public Sub 一键获取本文件夹工作表()Application.ScreenUpdating = FalseDim f As String, i As Integer '定义变量Dim wb As Excel.Workbook  '定义工作簿，也就是最后合并的表格Dim sh, sh1 As Excel.Worksheet '定义工作表Set sh1 = ThisWorkbook.Worksheets("导入清单")  'sh1为导入清单sheetIf Range("a65536").End(xlUp).Row > 1 Then 'A列最后一个有数据的单元所在的行数orA65535单元格向上，最后一个非空的单元格的行号sh1.Range("a2:b" & Range("a65536").End(xlUp).Row).ClearEnd Iff = Dir(ThisWorkbook.Path & "\*xls*") '获取地址Do While f <> "" '地址不为空时执行，<>在VBA在是不等于的意思If f <> ThisWorkbook.Name ThenSet wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)For i = 1 To Sheets.Countsh1.Range("a" & sh1.Range("a65536").End(xlUp).Row + 1) = wb.Name '导入清单sheet工作簿名称sh1.Range("b" & sh1.Range("b65536").End(xlUp).Row + 1) = Sheets(i).Name '导入清单sheet中工作表名称NextWorksheets.Copy Before:=Workbooks(ThisWorkbook.Name).Sheets(1)wb.Close TrueEnd Iff = DirLoopsh1.SelectApplication.ScreenUpdating = TrueMsgBox "已为您成功导入" & Sheets.Count - 1 & "张工作表" '提示框内容End Sub

学习目标2

将所有工作簿中的工作表复制粘贴到同一个sheet中
学习链接3

'VBA for merge excel files,.just support for Excel 2007
'Excel 2003 need change the codes
'Author:naiveloafer
'Date:2012-04-29
Sub naiveloafer()
Dim fs, f, f1, fc, s, x, rowss, columnss
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("C:\Users\gui\Desktop\工作\VBA学习\数据\复制粘贴测试\") '复制对象的路径
Set fc = f.Files
x = 1For Each f1 In fcIf Right(f1.Name, 4) = "xlsx" Then
Workbooks.Open (f1.Path)
rowss = Workbooks(f1.Name).Sheets(1).Range("A65536").End(xlUp).Row
columnss = Workbooks(f1.Name).Sheets(1).Columns.CountWorkbooks(f1.Name).Sheets(1).Range("A1:z" & CStr(rowss)).Copy
Workbooks(1).Activate
Workbooks(1).Sheets(1).Range("A" & CStr(x) & ":z" & CStr(x + rowss)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = Falsex = x + rowss
Workbooks(f1.Name).Close savechanges:=False
End IfNextEnd Sub

本文来自互联网用户投稿，文章观点仅代表作者本人，不代表本站立场，不承担相关法律责任。如若转载，请注明出处。 如若内容造成侵权/违法违规/事实不符，请点击【内容举报】进行投诉反馈！