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 = TrueEnd 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 = TrueEnd 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 = NothingEnd 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 cellEnd 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.ValueEnd Sub‘***********************************===================================================================问题30：如何实现当某一单元格满足非空条件时，输入的数据不能修改？ 如果在excel中写如此要求的一个函数：某一单元格满足非空条件时，输入的数据不能修改。就是当我往一个单元格内输入数据后，其中的数据无法再次修改！解答：代码如下：‘***********************************Private Sub Worksheet_SelectionChange(ByVal Target As Range)On Error Resume NextIf Target <> “” Then Target.Locked = True ActiveSheet.Protect password:=”123″End IfIf Target = “” Then ActiveSheet.Unprotect password:=”123″End IfEnd 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 WithEnd 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) NextEnd Sub
正确的寒暄必须在短短一句话中明显地表露出你对他的关怀。
