vba&copy&sheet
Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks.open("源文件.xls") '先打开要复制的文件
wkbk.sheets(1).Copy thisworkbook.sheets(1)
'再将此文件中第一个工作表复制到当前工作簿的第一个工作表前
这样是最简单的代码了，但是有些限制：如果工作表的某些单元格中字符数超过255个，则副本的该单元格中只保留前255个字符。
如果复制源文件中第一个工作表内容到当前工作簿第一个工作表中，用下列代码：
Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks("book2") '先打开要复制的文件
wkbk.Sheets(1).UsedRange.Copy '复制源文件中第一个工作表的内容
ThisWorkbook.Sheets(1).Range("A1").Paste '粘贴到当前工作簿第一个工作表中
本人最近利用记录宏的方式得到一条VBA语句以实现copy sheet 的功能. 语句如下:
Sheets("mainREPORT").Copy Before:=Sheets(4)
---------------------------------------------------------------------------------------------------------------
问题26：如何实现单元格在指定区域内自动跳转?例如，在单元格区域A1：C100中，无论何时在其中的某个单元格中输入完一个单个的字符后，自动按规律跳转到下一单元格，即在单元格B1中输完后，跳转到单元格C1，在单元格C1中输入完单个字符后，自动跳转到单元格A2，……
解答：可以在工作表事件中使用下面的代码：
‘***********************************Private
Sub Worksheet_Change(ByVal Target As Range)
WS_RANGE As String = "A1:C100" '&==
按需要改变单元格区域&&&&
&&& On Error
GoTo ws_exit
Application.EnableEvents = False
&&& If Not
Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
&&&&&&&&&&&
If Len(.Value) = 1 Then
&&&&&&&&&&&&&&&
Me.Cells(.Row - (.Column Mod 3 = 0), .Column Mod 3 +
&&&&&&&&&&&&&&&
If Intersect(ActiveCell, Me.Range(WS_RANGE)) Is Nothing Then
&&&&&&&&&&&&&&&&&&&
Me.Range(WS_RANGE).Cells(1, 1).Select
&&&&&&&&&&&&&&&
&&&&&&&&&&&
&&& End If
Application.EnableEvents = True
‘***********************************说明：该代码中的单元格区域可按您的需要改为合适的单元格区域，但必须是3列。
不限于列的代码如下：
‘***********************************Private
Sub Worksheet_Change(ByVal Target As Range)
&&& Dim Rng As
&&& Dim Ix As
Long, Ad As String
&&& Set Rng =
Range("F4:G50") '&==
按需要改变单元格区域&&&&
&&& On Error
GoTo ws_exit
Application.EnableEvents = False
&&& If Not
Intersect(Target, Rng) Is Nothing Then
If Len(Target.Value) = 1 Then
Ad = Target.Address(False, False, xlR1C1, , Rng)
Ix = Val(Mid(Ad, 3)) * Rng.Columns.Count + Val(Mid(Ad, InStr(Ad,
"C") + 2)) + 1
Rng((Ix Mod Rng.Cells.Count) + 1).Select
&&& End If
Application.EnableEvents = True
‘***********************************
说明：上面的代码中，单元格区域可不限于2列。
=====================================================================
问题27：如何将多个工作簿中的工作表一次性合到一个工作簿里面？解答：关于如何将多个工作簿（xls文件）中的工作表(worksheet）复制到同一个工作簿中的解决。下面的代码可以将某个磁盘目录下的多个xls文件的复制到含有这段代码的xls文件中，而且xls文件可以根据处理worksheet的数量自动的增加xls文件中worksheet的数量。使用时将代码复制到xls文件的宏内，然后运行宏main即可。
代码中运用了filesystemobject对象和excel的range对象的copy方法以及worksheet和workbook对象的add方法。这里就不在赘述，可以在excel
vba的帮助中找到。
‘***********************************Sub
Mergesheet(ByVal sPath As String)
&& Dim fs, fd, fl As
&& Dim xlbook As Workbook
&& Dim xlsheet As Worksheet
&& Dim i_cnt As Integer
&& i_cnt = 1
&& Set fs =
CreateObject("scripting.filesystemobject") '建立filesystemobject
fs.FolderExists(sPath) Then
MsgBox "目录不存在！", vbCritical
&&& Set fd =
fs.getfolder(sPath)&&
'或取文件夹&&&
For Each fl In
fd.Files&&&&&&&
'依此处理文件夹中的文件&&&&&
If Right(Trim(fl.Name), 3) = "xls"
'只处理xls文件&&&&&&&
Set xlbook = Application.Workbooks.Open(sPath + "/" +
fl.Name)& '打开xls文件&&&&&&&
If i_cnt && 3
Then&&&&&&&&
'默认的worksheet数量是3,如果超过就自动的增加&&&&&&&&&
Set xlsheet = Application.Workbooks(1).Worksheets.Add
Set xlsheet = Application.Workbooks(1).Worksheets(i_cnt)
xlbook.Worksheets(1).Rows.Copy xlsheet.Cells(1,
1)&'复制worksheet&&&&&&&
i_cnt = i_cnt + 1
xlbook.Close&&&&&&&&&&&&
'关闭已经打开的xls文件&&&&&
&&& Set fl =
Nothing&&&&&&&&&&&'关闭file,folder,filesystemobject对象
fd = Nothing
&&& Set fs =
Sub main()
& Dim sPath As String
& sPath = InputBox("请输入目录！如C:",
"合并目录下xls文件的sheet1")& '显示输入框获取磁盘目录& If
sPath = " " Then Exit Sub
& Mergesheet (sPath)
‘***********************************===================================================================
问题28：关于Excel单元格填充颜色......？有五种可能的计算结果，比如结果会是1,2,3,4,5，不同的值给单元格填充不同颜色。条件格式最多只能定义三个条件，即只能填充最多三种颜色，不知用什么方法可以填上三种以上的颜色？
解答： 如果所有的结果集合只是在1，2，3，4，5中间，那么写个宏就OK。
假设对于$B这一整列的情况如下：
B1=0或空时，单元格B1无填充颜色；
B1=1 时，给单元格B1填充红色；
B1=2 时，给单元格B1填充蓝色；
B1=3 时，给单元格B1填充绿色；
B1=4 时，给单元格B1填充黄色；
B1=5 时，给单元格B1填充紫色。
B2=0或空时，单元格B2无填充颜色；
B2=1 时，给单元格B2填充红色；
B2=2 时，给单元格B2填充蓝色；
B2=3 时，给单元格B2填充绿色；
B2=4 时，给单元格B2填充黄色；
B2=5 时，给单元格B2填充紫色。
‘***********************************Sub
& For i = 1 To 4096 ‘要填充颜色的单元格，可修改为所需要的&&&
Range("B" + CStr(i)).Select
&&& Select Case
Range("B" + CStr(i)).Cells.Value
&&& Case 1
& Selection.Interior.ColorIndex = 3
&&& Case 2
Selection.Interior.ColorIndex = 4
& & Case 3
& Selection.Interior.ColorIndex = 5
& & Case 4
& Selection.Interior.ColorIndex = 6
& & Case 5
&& Selection.Interior.ColorIndex
& & With Selection.Interior
& .Pattern = xlSolid
&& .PatternColorIndex =
xlAutomatic
‘***********************************---------------------------------------------------------------------
如果要做到单元格的值改变后填充的颜色自动更新，这个宏该改成怎样？
如果单元格的值是计算得来的，用 worksheet Calculate Event 应该可以。
‘***********************************Private
Sub Worksheet_Calculate()
& Dim vValue As Integer
& Dim vColor As Integer
& Dim cRange As Range
& Dim cell As Range
&&For Each cell In
Intersect(Columns("B"), ActiveSheet.UsedRange)
& & vValue = cell.Value
'默认值无填充色& & vColor =
& & Select Case vValue
& & Case 1
&&& vColor =
& & Case 2
&&& vColor =
& & Case 3
&&& vColor =
& & Case 4
&&& vColor =
& & Case 5
&&& vColor =
& & End Select
Application.EnableEvents = False
&cell.Interior.ColorIndex = vColor
Application.EnableEvents = True
& Next cell
‘***********************************(
如果单元格的值不是计算得来的，是直接输入的，可以改用 Worksheet Change Event )
---------------------------------------------------------------------
还想问一下，这个宏的功能能否用自定义函数做到？
想用自定义函数的原因：单元格锁定时，自定义函数依然可以正常运行，而宏不行。
这个可以利用 UserInterfaceOnly ＝ TRUE 参数去解决。将 UserInterfaceOnly 参数设置为
True 可以允许通过代码修改，但是不允许通过用户界面修改。默认值为
False，这意味着通过代码和用户界面项都不可以修改受保护的工作表。这个属性设置只适用于当前会话。如果您想让代码可以在任何会话中都可以操作工作表，那么您需要每次工作簿打开的时候添加设置这个属性的代码。
注意红色那段字，由于这个原因，所以加一个宏在 workbook open event
让每次开启档案时去设定UserInterfaceOnly 参数。
‘***********************************Private
Sub Workbook_Open()
'如果每个工作表都有不同的密码& Sheets(1).Protect
Password:="secret1", UserInterFaceOnly:=True
& Sheets(2).Protect Password:="secret2",
UserInterFaceOnly:=True
'按需要重复
'**如果所有工作表密码相同
&& 'Dim wSheet As Worksheet
&& 'For Each wSheet In
Worksheets
wSheet.Protect Password:="secret", UserInterFaceOnly:=True
&& 'Next wSheet
'****End Sub
‘***********************************必须了解的一些相关概念(陈希章,微软中文新闻组专家)
一般我们在指定颜色时喜欢用ColorIndex这个属性,通常情况下是没有问题的。
但必须知道的一些概念是:ColorIndex是相对于调色盘中(调色盘有56中颜色)的某个位置的颜色,而调色盘是属于工作簿级的对象,也就是说很有可能这样一种情况就是,在这个工作簿中3代表红色(假设),而到另一个工作簿中却不是。
所以,如果要精确定义颜色,是不推荐用ColorIndex的,往往有些同志在调试程序时的疑惑也在于此(明明在自己电脑上是红色,到用户电脑上就不是了)。
还有两种方法来返回颜色：
1.用Excel常量,如vbred,vbblue,vbgreen等。
2.用RGB函数。
用以上的方法,VBA语句也应相应更改。
例:Target.Offset(0, 1).Interior.ColorIndex = vColor
改成'Target.Offset(0, 1).Interior.Color = vbred 等等。
另从本例而言,建议统一用change事件。
===================================================================
问题29：如何实现在Sheet1中输入后，在Sheet2中相应的单元格中显示？即，如何实现在
sheet1中输入a1=abc，sheet2中显示a1=
输入b1=xyz，sheet2中显示a2=
再输入a2=123，sheet2中显示a5=123;
&&&&&&&&&&&&
输入b2=qwe, sheet2中显示a6=
不停的输入后，sheet2中数字每四行四行不停填充。
代码说明，这个需求的关键是，需要建立sheet1的行列值与sheet2的行值之间的函数关系，综合看就是一个代数系统内的等差数列的关系。
这个代数式就是：
j=(i-1)*4+t&&
j代表sheet2的行值，i代表sheet1的行值，t代表sheet1的列值。
所以能够按照所描述的功能的vba代码如下：
‘***********************************'这是sheet1的worksheet_change事件(触发的条件就是在sheet1输入数据)
Private Sub Worksheet_Change(ByVal Target As
Target.Column & 2
Then&& '这里限定最大只可以输入到每行的第2列,否则就不处理&&&&&
MsgBox "输错了位置", vbCritical&'这里是错误的提示信息&&&
Sub&&&&&&&&&&&&&&&&&&&&&&&&
'退出代码的执行&&&
'按照sheet1与sheet2行列的特定算法填充数据
&& Sheet2.Cells((Target.Row - 1)
* 4 + Target.Column, 1) = Target.Value
‘***********************************===================================================================
问题30：如何实现当某一单元格满足非空条件时，输入的数据不能修改？
如果在excel中写如此要求的一个函数：某一单元格满足非空条件时，输入的数据不能修改。就是当我往一个单元格内输入数据后，其中的数据无法再次修改！
解答：代码如下：
‘***********************************Private
Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target && "" Then
&& Target.Locked = True
&& ActiveSheet.Protect
password:="123"
If Target = "" Then
&& ActiveSheet.Unprotect
password:="123"
‘***********************************===================================================================
问题31：如何用Vba方法导出Xls文件至Txt文件？即如何以一定的格式输出Excel文件的数据。
这是个常见的问题，因为许多不同应用系统之间报送数据时，最好的方法就是报送统一格式的数据文件，而带有特殊分割符号的文本文件应该说是最适用的。
下面的代码将输出的文件改为“文件名”+“Worksheet名”组合的TXT文件。代码的适当说明：生成Txt文件需要使用FileSystemObject对象，关于该对象的说明，可以参阅msdn或vba帮助中的相关内容。这段程序可以在将xls文件中任意的sheet中的内容导出成txt文本文件。
如下就是代码。可以将其复制到任何一个xls文件中。使用时，只要打开某个sheet，然后运行这个宏（菜单内：工具-〉宏-〉运行宏OutPutXlsToTxt），即可将该sheet内的数据导出生成TXT文件，文件名是由Excel文件名和Sheet名组合而成的。
‘***********************************Sub
OutPutXlsToTxt()
& Dim fs, myFile As Object
& Dim i_row, i_col, i_MaxCol As Integer
'xls工作表的行列坐标变量和最大列数变量&
Dim myfileline As String'txtfile的行数据&
& Set fs =
CreateObject("Scripting.FileSystemObject")&&'建立filesytemobject
&'通过filesystemobject新建一个和xls文件同名的txt文件&
Set myFile = fs.createtextfile(Workbooks(1).Path + "/" + _
Mid(Trim(Workbooks(1).Name), 1, Len(Trim(Workbooks(1).Name)) - 4) +
Trim(Workbooks(1).ActiveSheet.Name) +
& i_row = 1
& i_MaxCol = 0
&&& i_MaxCol =
i_MaxCol + 1
& Loop Until Workbooks(1).ActiveSheet.Cells(1,
i_MaxCol) = ""
& i_MaxCol = i_MaxCol -
'获得整个sheet的最大列数&
If i_MaxCol = 0
Then&&&&&&
'对没有数据的表不做处理并退出程序&&&
MsgBox "该表无数据,不能导出!", vbCritical
&&& myfileline =
&&& For i_col =
1 To i_MaxCol
myfileline = myfileline + _
Trim(CStr(Workbooks(1).ActiveSheet.Cells(i_row, i_col))) +
","&'生成每行数据&&&
myFile.writeline (Mid(myfileline, 1, Len(myfileline) -
1))& '将每行数据写入txtfile&&&
i_row = i_row + 1
& Loop Until Workbooks(1).ActiveSheet.Cells(i_row,
& Set myFile = Nothing
& Set fs =
Nothing&&&&&&&&&&&&&&&&&&
'关闭文件和filesystemobject对象
-------------------------------------------------------------------------------------------------------------------------------------------------
Sub Zldccmx()
ThisWorkbook.Worksheets("2of2")
For i = 3 To 8
arr = Application.Transpose(Application.Transpose(.Range("A"
& i).Resize(1, .Range("IV" &
i).End(xlToLeft).Column)))
ThisWorkbook.Sheets(arr).Copy
-----------------------------------------------------------------------------------------------------------------------------------------------------
Sub Zldccmx()
&&& For i = 3 To
Application.WorksheetFunction.Transpose(Application.Transpose(Range("A"
& i).Resize(1, Range("IV" &
i).End(xlToLeft).Column)))
Sheets(Arr).Copy
after:=Workbooks(1).Sheets(1)
已投稿到：后使用快捷导航没有帐号？
查看: 12257|回复: 4
威望68 贡献43 性别男在线时间0 小时最后登录帖子精华0阅读权限10注册时间相册
士长(LV1), 积分 68, 距离下一级还需 32 积分
贡献43 威望68 主题帖子
表格见附件
如何在EXCEL中将Sheet1中含有指定内容的行全部复制到Sheet2中
例如，图片中的A列，要将其中所有含有“甲”内容的行都复制到Sheet2中，而且Sheet1中A列的内容如果增加或减少时Sheet2中的内容也会随即改动
如果A列增加了一个“甲”，那么在Sheet2中也会增加与含有“甲”那一行相同的一行
我的意思就是，要把Sheet1中“甲”所对应的行全部复制到Sheet2中
表达的好像不是太明确，如果不清楚可以再问我
谢谢！\r\n问题补充：wodaxiaopengyo和芮城老憨给的函数只能复制出3列，怎么样能复制很多列？
要改哪一个变量？应该怎么改？
威望1285 贡献70 性别男在线时间0 小时最后登录帖子精华0阅读权限40注册时间相册
上尉(LV4), 积分 1285, 距离下一级还需 715 积分
贡献70 威望1285 主题帖子
最好是使用VBA，方便很多。直接刷新过去，不需要频繁地添加一些函数
威望60 贡献11 性别男在线时间0 小时最后登录帖子精华0阅读权限10注册时间相册
士长(LV1), 积分 60, 距离下一级还需 40 积分
贡献11 威望60 主题帖子
使用辅助列，轻松解决你的问题把问题作为内容、样表（03版，把现状和目标效果表示出来）作为附件发来看下
威望46 贡献82 性别男在线时间0 小时最后登录帖子精华0阅读权限10注册时间相册
士兵(LV0), 积分 46, 距离下一级还需 4 积分
贡献82 威望46 主题帖子
在sheet2的A1单元格中输入公式:
=IF(ROW()&COUNTIF(Sheet1!$A:$A,"甲"),"",INDEX(Sheet1!$A$1:$C$100,SMALL(IF(Sheet1!$A$1:$A$100="甲",ROW($1:$100),4^8),ROW()),COLUMN()))
回车后按一下F2,再按shift+ctrl+回车,然后选中A1单元格向下向右复制公式,注意向下多复制一些行,以备你在表一中添加信息后表二也能随时更新.
威望79 贡献29 性别男在线时间0 小时最后登录帖子精华0阅读权限10注册时间相册
士长(LV1), 积分 79, 距离下一级还需 21 积分
贡献29 威望79 主题帖子
用公式你如果不太明白相对与绝对引用的话，很容易搞错，不如用宏。
随便录制一个宏，编辑它，把里面所有的字清除掉，然后贴上下面的代码，运行就可以了，你也可以指定快捷键，这样更好操作。
运行时，会弹出一个对话框，要求你输入要筛选的内容，如：甲，这样所有首列是甲的行都会复制到Sheet2当中去，绝无遗漏。Sheet1中内容更换后只要再运行一遍这个宏就可以了，也就0.1秒吧。
SubmyCopy()
Dimmm,nn,myStr,i
mm=ActiveSheet.[a65536].End(xlUp).Row
nn=Worksheets("sheet2").[a65536].End(xlUp).Row+1
myStr=InputBox("Plsinputfilteringwordbelow")
Debug.PmyStr
Fori=1Tomm
IfCells(i,1)=myStrThen
Rows(i).EntireRow.CopyWorksheets("sheet2").Cells(nn,1)
Powered by(window.slotbydup=window.slotbydup || []).push({
id: '2081942',
container: s,
size: '1000,60',
display: 'inlay-fix'我想用VBA实现多个工作薄中的数据复制到一个工作薄中，写了一段代码，但是运行时报错：应用程序定义或对象定义错误 1004，该怎么改。
[问题点数：100分，结帖人tzy3169]
我想用VBA实现多个工作薄中的数据复制到一个工作薄中，写了一段代码，但是运行时报错：应用程序定义或对象定义错误 1004，该怎么改。
[问题点数：100分，结帖人tzy3169]
不显示删除回复
显示所有回复
显示星级回复
显示得分回复
只显示楼主
匿名用户不能发表回复！|
每天回帖即可获得10分可用分！小技巧：
你还可以输入10000个字符
(Ctrl+Enter)
请遵守CSDN，不得违反国家法律法规。
转载文章请注明出自“CSDN（www.csdn.net）”。如是商业用途请联系原作者。