作者:乔山办公网日期:
返回目录: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