Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks.open("源文件.xls") '先打开要复制的文件
wkbk.sheets(1).Copy thisworkbook.sheets(1) '再将此文件中第一个工作表复制到当前工作簿的第一个工作表前
End Sub
这样是最简单的代码了，但是有些限制：如果工作表的某些单元格中字符数超过255个，则副本的该单元格中只保留前255个字符。
如果复制源文件中第一个工作表内容到当前工作簿第一个工作表中，用下列代码：
Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks("book2") '先打开要复制的文件
wkbk.Sheets(1).UsedRange.Copy '复制源文件中第一个工作表的内容
ThisWorkbook.Sheets(1).Range("A1").Paste '粘贴到当前工作簿第一个工作表中
End Sub
本人最近利用记录宏的方式得到一条VBA语句以实现copy sheet 的功能. 语句如下:
Sheets("mainREPORT").Copy Before:=Sheets(4)
---------------------------------------------------------------------------------------------------------------
问题26：如何实现单元格在指定区域内自动跳转?
例如，在单元格区域A1：C100中，无论何时在其中的某个单元格中输入完一个单个的字符后，自动按规律跳转到下一单元格，即在单元格B1中输完后，跳转到单元格C1，在单元格C1中输入完单个字符后，自动跳转到单元格A2，……
解答：可以在工作表事件中使用下面的代码：
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
Const 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 + 1).Select
If Intersect(ActiveCell, Me.Range(WS_RANGE)) Is Nothing Then
Me.Range(WS_RANGE).Cells(1, 1).Select
End If
End If
End With
End If
ws_exit:
Application.EnableEvents = True
End Sub
‘***********************************
说明：该代码中的单元格区域可按您的需要改为合适的单元格区域，但必须是3列。
不限于列的代码如下：
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
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
End If
ws_exit:
Application.EnableEvents = True
End Sub
‘***********************************
说明：上面的代码中，单元格区域可不限于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 Object
Dim xlbook As Workbook
Dim xlsheet As Worksheet
Dim i_cnt As Integer
i_cnt = 1
Set fs = CreateObject("scripting.filesystemobject") '建立filesystemobject
If Not fs.FolderExists(sPath) Then
MsgBox "目录不存在！", vbCritical
Exit Sub
End If
Set fd = fs.getfolder(sPath) '或取文件夹
For Each fl In fd.Files '依此处理文件夹中的文件
If Right(Trim(fl.Name), 3) = "xls" Then '只处理xls文件
Set xlbook = Application.Workbooks.Open(sPath + "/" + fl.Name) '打开xls文件
If i_cnt <> 3 Then '默认的worksheet数量是3,如果超过就自动的增加
Set xlsheet = Application.Workbooks(1).Worksheets.Add
Else
Set xlsheet = Application.Workbooks(1).Worksheets(i_cnt)
End If
xlbook.Worksheets(1).Rows.Copy xlsheet.Cells(1, 1) '复制worksheet
i_cnt = i_cnt + 1
xlbook.Close '关闭已经打开的xls文件
End If
Next
Set fl = Nothing '关闭file,folder,filesystemobject对象
Set fd = Nothing
Set fs = Nothing
End Sub
Sub main()
Dim sPath As String
sPath = InputBox("请输入目录！如C:", "合并目录下xls文件的sheet1") '显示输入框获取磁盘目录
If sPath = " " Then Exit Sub
Mergesheet (sPath)
End Sub
‘***********************************
===================================================================
问题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 Macro1()
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 = 7
End Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Next
End Sub
‘***********************************
---------------------------------------------------------------------
如果要做到单元格的值改变后填充的颜色自动更新，这个宏该改成怎样？
如果单元格的值是计算得来的，用 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 = 0
Select Case vValue
Case 1
vColor = 3
Case 2
vColor = 5
Case 3
vColor = 4
Case 4
vColor = 6
Case 5
vColor = 13
End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = vColor
Application.EnableEvents = True
Next cell
End Sub
‘***********************************
( 如果单元格的值不是计算得来的，是直接输入的，可以改用 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=abc;
输入b1=xyz，sheet2中显示a2=xyz;
再输入a2=123，sheet2中显示a5=123;
输入b2=qwe, sheet2中显示a6=qwe;
不停的输入后，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 Range)
If Target.Column > 2 Then '这里限定最大只可以输入到每行的第2列,否则就不处理
MsgBox "输错了位置", vbCritical '这里是错误的提示信息
Exit Sub '退出代码的执行
End If
'按照sheet1与sheet2行列的特定算法填充数据
Sheet2.Cells((Target.Row - 1) * 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
问题30：如何实现当某一单元格满足非空条件时，输入的数据不能修改？
如果在excel中写如此要求的一个函数：某一单元格满足非空条件时，输入的数据不能修改。就是当我往一个单元格内输入数据后，其中的数据无法再次修改！
解答：代码如下：
‘***********************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target <> "" Then
Target.Locked = True
ActiveSheet.Protect password:="123"
End If
If Target = "" Then
ActiveSheet.Unprotect password:="123"
End If
End Sub
‘***********************************
===================================================================
问题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) + ".txt")
i_row = 1
i_MaxCol = 0
Do
i_MaxCol = i_MaxCol + 1
Loop Until Workbooks(1).ActiveSheet.Cells(1, i_MaxCol) = ""
i_MaxCol = i_MaxCol - 1 '获得整个sheet的最大列数
If i_MaxCol = 0 Then '对没有数据的表不做处理并退出程序
MsgBox "该表无数据,不能导出!", vbCritical
Exit Sub
End If
Do
myfileline = ""
For i_col = 1 To i_MaxCol
myfileline = myfileline + _
Trim(CStr(Workbooks(1).ActiveSheet.Cells(i_row, i_col))) + "," '生成每行数据
Next
myFile.writeline (Mid(myfileline, 1, Len(myfileline) - 1)) '将每行数据写入txtfile
i_row = i_row + 1
Loop Until Workbooks(1).ActiveSheet.Cells(i_row, 1) = ""
Set myFile = Nothing
Set fs = Nothing '关闭文件和filesystemobject对象
-------------------------------------------------------------------------------------------------------------------------------------------------
Sub Zldccmx()
With 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
Next
End With
End Sub
-----------------------------------------------------------------------------------------------------------------------------------------------------
Sub Zldccmx()
For i = 3 To 8
Arr = Application.WorksheetFunction.Transpose(Application.Transpose(Range("A" & i).Resize(1, Range("IV" & i).End(xlToLeft).Column)))
Sheets(Arr).Copy after:=Workbooks(1).Sheets(1)
Next
End Sub
扫一扫
2410
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
