乔山办公网我们一直在努力
您的位置:乔山办公网 > excel表格制作 > 如何用VBA把一个工作簿中的工作表内容复制到另一个汇总工作簿...

如何用VBA把一个工作簿中的工作表内容复制到另一个汇总工作簿...

作者:乔山办公网日期:

返回目录:excel表格制作


答:e799bee5baa6e997aee7ad94e58685e5aeb9336

Sub CopyToFile()
    Dim Wb As Workbook, sFile As String
    Dim Rng As Range, C As Range
    Dim FirstAddress As String
    Dim Sht As Worksheet
    
    sPath = ThisWorkbook.Path & "\测试文件夹\"
    sFile = Dir(sPath & "*.xls*")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Rng = Sheets("名字1").Range("C1:D4")
    Do While sFile <> ""
        Set Wb = Workbooks.Open(sPath & sFile)
        For Each Sht In Wb.Worksheets
            With Sht
                Set C = .UsedRange.Find(what:="总计", lookat:=xlWhole)
                If Not C Is Nothing Then
                    FirstAddress = C.Address
                    Do
                        Rng.Copy C.Offset(0, 1)
                        Set C = .UsedRange.FindNext(C)
                    Loop While Not C Is Nothing And C.Address <> FirstAddress
                End If
            End With
        Next Sht
        Wb.Close savechanges:=True
        sFile = Dir
    Loop
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub


private Sub bookMerge(nstart As Long, ncolumn As Integer)
' MsgBox "欢迎使用合并工作表工具1.0" & Chr(13) & "made by excel880工作室" & Chr(13) _
' & "本工具将合并当前目录下所有工作簿的7a64e4b893e5b19e330第一个工作表到一个工作簿"
'
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)
sub test()
dim arr()
dim row1 as long
dim row2 as long

row1=sheet1.range("A65536").end(xlup).row
redim arr(1 to row1,1 to 3)
arr=sheet1.range("A1:C" & row1)

row2=2
application.screenupdating=false
for i=1 to row1
if arr(i,1)=sheet2.cells(j,1) then
sheet2.cells(j,2)=arr(i,2)
sheet2.cells(j,3)=arr(i,3)
j=j+1
end if
next i
application.screenupdating=true

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) '打开工e799bee5baa6e997aee7ad94e59b9ee7ad94336作簿
                '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

相关阅读

关键词不能为空
极力推荐
  • 如何把EXCEL文本格式里的数字批量转成文本

  •   把文本格式批量转换为数值格式,步骤是:  在空白单元格中输入1,右击该单元格、复制,然后选文本型数字区域,右击,“选择性粘贴”注意勾选“乘”。  具体操作见图 

ppt怎么做_excel表格制作_office365_word文档_365办公网