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

轉載于:https://www.cnblogs.com/alicesunBlog/archive/2013/03/25/2980569.html

總結

以上是生活随笔為你收集整理的vba copy sheet的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。