我想用vba代码把一个文件中某一个sheet里指定区域内容复制到另一个汇总工作簿里一个指定shee
答案:1 悬赏:10 手机版
解决时间 2021-02-08 22:53
- 提问者网友:练爱
- 2021-02-08 10:36
我想用vba代码把一个文件中某一个sheet里指定区域内容复制到另一个汇总工作簿里一个指定shee
最佳答案
- 五星知识达人网友:举杯邀酒敬孤独
- 2021-02-08 10:53
参考代码
private Sub bookMerge(nstart As Long, ncolumn As Integer)
' MsgBox "欢迎使用合并工作表工具1.0" & Chr(13) & "made by excel880工作室" & Chr(13) _
' & "本工具将合并当前目录下所有工作簿的第一个工作表到一个工作簿"
'
Dim fs, f, f1, fc, s
Dim wk As Workbook, sht As Worksheet
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ThisWorkbook.Path)
Set fc = f.Files
Set targetWk = Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\合并.xls"
Set targetSht = ActiveWorkbook.Sheets(1)
targetSht.Name = "合并"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' Set targetWk = Workbooks.Open(ThisWorkbook.Path & "\" & "合并.xls")
' Set targetSht = targetWk.Sheets(1)
k = nstart '目标表的行标
For Each f1 In fc '遍历文件夹文件
If f1.Name <> ThisWorkbook.Name And Right(f1.Name, 3) = "xls" And f1.Name <> "合并.xls" Then
Set wk = Workbooks.Open(ThisWorkbook.Path & "\" & f1.Name) '打开工作簿
'wk.Sheets(1).Copy Before:=Workbooks("合并工作表.xls").Sheets("xx")
'ThisWorkbook.Sheets("Sheet1").Name = Left(f1.Name, Len(f1.Name) - 4)
Set sht = wk.ActiveSheet
If k = nstart Then '复制粘贴表头
sht.Rows(1 & ":" & (nstart - 1)).Copy
targetSht.Activate
targetSht.Cells(1, 1).Select
ActiveSheet.Paste '粘贴表头
End If
'************复制粘贴数据************
irow = nstart '行标
While sht.Cells(irow + 1, ncolumn) <> "" '以第ncolumn列数据为结束标示,确定源表的行数
irow = irow + 1
Wend
sht.Rows(nstart & ":" & irow).Copy '复制源数据行
targetSht.Activate
targetSht.Cells(k, 1).Select
ActiveSheet.Paste '粘贴数据
k = k + irow - nstart + 1
's = s & f1.Name
's = s & vbCrLf
wk.Close
End If
Next
targetWk.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisWorkbook.Close SaveChanges:=True
'MsgBox s
End Sub
private Sub bookMerge(nstart As Long, ncolumn As Integer)
' MsgBox "欢迎使用合并工作表工具1.0" & Chr(13) & "made by excel880工作室" & Chr(13) _
' & "本工具将合并当前目录下所有工作簿的第一个工作表到一个工作簿"
'
Dim fs, f, f1, fc, s
Dim wk As Workbook, sht As Worksheet
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ThisWorkbook.Path)
Set fc = f.Files
Set targetWk = Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\合并.xls"
Set targetSht = ActiveWorkbook.Sheets(1)
targetSht.Name = "合并"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' Set targetWk = Workbooks.Open(ThisWorkbook.Path & "\" & "合并.xls")
' Set targetSht = targetWk.Sheets(1)
k = nstart '目标表的行标
For Each f1 In fc '遍历文件夹文件
If f1.Name <> ThisWorkbook.Name And Right(f1.Name, 3) = "xls" And f1.Name <> "合并.xls" Then
Set wk = Workbooks.Open(ThisWorkbook.Path & "\" & f1.Name) '打开工作簿
'wk.Sheets(1).Copy Before:=Workbooks("合并工作表.xls").Sheets("xx")
'ThisWorkbook.Sheets("Sheet1").Name = Left(f1.Name, Len(f1.Name) - 4)
Set sht = wk.ActiveSheet
If k = nstart Then '复制粘贴表头
sht.Rows(1 & ":" & (nstart - 1)).Copy
targetSht.Activate
targetSht.Cells(1, 1).Select
ActiveSheet.Paste '粘贴表头
End If
'************复制粘贴数据************
irow = nstart '行标
While sht.Cells(irow + 1, ncolumn) <> "" '以第ncolumn列数据为结束标示,确定源表的行数
irow = irow + 1
Wend
sht.Rows(nstart & ":" & irow).Copy '复制源数据行
targetSht.Activate
targetSht.Cells(k, 1).Select
ActiveSheet.Paste '粘贴数据
k = k + irow - nstart + 1
's = s & f1.Name
's = s & vbCrLf
wk.Close
End If
Next
targetWk.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisWorkbook.Close SaveChanges:=True
'MsgBox s
End Sub
我要举报
如以上问答信息为低俗、色情、不良、暴力、侵权、涉及违法等信息,可以点下面链接进行举报!
大家都在看
推荐资讯