vba copy sheet 收藏
Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks.open("源文件.xls") '先打開要復制的文件
wkbk.sheets(1).Copy thisworkbook.sheets(1) '再將此文件中第一個工作表復制到當前工作簿的第一個工作表前
End Sub
這樣是最簡單的代碼了，但是有些限制：如果工作表的某些單元格中字符數(shù)超過255個，則副本的該單元格中只保留前255個字符。
如果復制源文件中第一個工作表內(nèi)容到當前工作簿第一個工作表中，用下列代碼：
Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks("book2") '先打開要復制的文件
wkbk.Sheets(1).UsedRange.Copy '復制源文件中第一個工作表的內(nèi)容
ThisWorkbook.Sheets(1).Range("A1").Paste '粘貼到當前工作簿第一個工作表中
End Sub
本人最近利用記錄宏的方式得到一條VBA語句以實現(xiàn)copy sheet 的功能. 語句如下:
Sheets("mainREPORT").Copy Before:=Sheets(4)
---------------------------------------------------------------------------------------------------------------
問題26：如何實現(xiàn)單元格在指定區(qū)域內(nèi)自動跳轉(zhuǎn)?
例如，在單元格區(qū)域A1：C100中，無論何時在其中的某個單元格中輸入完一個單個的字符后，自動按規(guī)律跳轉(zhuǎn)到下一單元格，即在單元格B1中輸完后，跳轉(zhuǎn)到單元格C1，在單元格C1中輸入完單個字符后，自動跳轉(zhuǎn)到單元格A2，……
解答：可以在工作表事件中使用下面的代碼：
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:C100" '<== 按需要改變單元格區(qū)域
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
‘***********************************
說明：該代碼中的單元格區(qū)域可按您的需要改為合適的單元格區(qū)域，但必須是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") '<== 按需要改變單元格區(qū)域
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
‘***********************************
說明：上面的代碼中，單元格區(qū)域可不限于2列。
=====================================================================
問題27：如何將多個工作簿中的工作表一次性合到一個工作簿里面？
解答：關于如何將多個工作簿（xls文件）中的工作表(worksheet）復制到同一個工作簿中的解決。下面的代碼可以將某個磁盤目錄下的多個xls文件的復制到含有這段代碼的xls文件中，而且xls文件可以根據(jù)處理worksheet的數(shù)量自動的增加xls文件中worksheet的數(shù)量。使用時將代碼復制到xls文件的宏內(nèi)，然后運行宏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數(shù)量是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 '關閉已經(jīng)打開的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單元格填充顏色......？
有五種可能的計算結(jié)果，比如結(jié)果會是1,2,3,4,5，不同的值給單元格填充不同顏色。條件格式最多只能定義三個條件，即只能填充最多三種顏色，不知用什么方法可以填上三種以上的顏色？
解答： 如果所有的結(jié)果集合只是在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 )
---------------------------------------------------------------------
還想問一下，這個宏的功能能否用自定義函數(shù)做到？
想用自定義函數(shù)的原因：單元格鎖定時，自定義函數(shù)依然可以正常運行，而宏不行。
這個可以利用 UserInterfaceOnly ＝ TRUE 參數(shù)去解決。將 UserInterfaceOnly 參數(shù)設置為 True 可以允許通過代碼修改，但是不允許通過用戶界面修改。默認值為 False，這意味著通過代碼和用戶界面項都不可以修改受保護的工作表。這個屬性設置只適用于當前會話。如果您想讓代碼可以在任何會話中都可以操作工作表，那么您需要每次工作簿打開的時候添加設置這個屬性的代碼。
注意紅色那段字，由于這個原因，所以加一個宏在 workbook open event 讓每次開啟檔案時去設定UserInterfaceOnly 參數(shù)。
代碼；
‘***********************************
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是相對于調(diào)色盤中(調(diào)色盤有56中顏色)的某個位置的顏色,而調(diào)色盤是屬于工作簿級的對象,也就是說很有可能這樣一種情況就是,在這個工作簿中3代表紅色(假設),而到另一個工作簿中卻不是。
所以,如果要精確定義顏色,是不推薦用ColorIndex的,往往有些同志在調(diào)試程序時的疑惑也在于此(明明在自己電腦上是紅色,到用戶電腦上就不是了)。
還有兩種方法來返回顏色：
1.用Excel常量,如vbred,vbblue,vbgreen等。
2.用RGB函數(shù)。
用以上的方法,VBA語句也應相應更改。
例:Target.Offset(0, 1).Interior.ColorIndex = vColor 改成'Target.Offset(0, 1).Interior.Color = vbred 等等。
另從本例而言,建議統(tǒng)一用change事件。
===================================================================
問題29：如何實現(xiàn)在Sheet1中輸入后，在Sheet2中相應的單元格中顯示？
即，如何實現(xiàn)在
sheet1中輸入a1=abc，sheet2中顯示a1=abc;
輸入b1=xyz，sheet2中顯示a2=xyz;
再輸入a2=123，sheet2中顯示a5=123;
輸入b2=qwe, sheet2中顯示a6=qwe;
不停的輸入后，sheet2中數(shù)字每四行四行不停填充。
解答：
代碼說明，這個需求的關鍵是，需要建立sheet1的行列值與sheet2的行值之間的函數(shù)關系，綜合看就是一個代數(shù)系統(tǒng)內(nèi)的等差數(shù)列的關系。 這個代數(shù)式就是：
j=(i-1)*4+t j代表sheet2的行值，i代表sheet1的行值，t代表sheet1的列值。
所以能夠按照所描述的功能的vba代碼如下：
‘***********************************
'這是sheet1的worksheet_change事件(觸發(fā)的條件就是在sheet1輸入數(shù)據(jù))
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 2 Then '這里限定最大只可以輸入到每行的第2列,否則就不處理
MsgBox "輸錯了位置", vbCritical '這里是錯誤的提示信息
Exit Sub '退出代碼的執(zhí)行
End If
'按照sheet1與sheet2行列的特定算法填充數(shù)據(jù)
Sheet2.Cells((Target.Row - 1) * 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
問題30：如何實現(xiàn)當某一單元格滿足非空條件時，輸入的數(shù)據(jù)不能修改？
如果在excel中寫如此要求的一個函數(shù)：某一單元格滿足非空條件時，輸入的數(shù)據(jù)不能修改。就是當我往一個單元格內(nèi)輸入數(shù)據(jù)后，其中的數(shù)據(jù)無法再次修改！
解答：代碼如下：
‘***********************************
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文件的數(shù)據(jù)。
解答：
這是個常見的問題，因為許多不同應用系統(tǒng)之間報送數(shù)據(jù)時，最好的方法就是報送統(tǒng)一格式的數(shù)據(jù)文件，而帶有特殊分割符號的文本文件應該說是最適用的。
下面的代碼將輸出的文件改為“文件名”+“Worksheet名”組合的TXT文件。代碼的適當說明：生成Txt文件需要使用FileSystemObject對象，關于該對象的說明，可以參閱msdn或vba幫助中的相關內(nèi)容。這段程序可以在將xls文件中任意的sheet中的內(nèi)容導出成txt文本文件。
如下就是代碼?？梢詫⑵鋸椭频饺魏我粋€xls文件中。使用時，只要打開某個sheet，然后運行這個宏（菜單內(nèi)：工具-〉宏-〉運行宏OutPutXlsToTxt），即可將該sheet內(nèi)的數(shù)據(jù)導出生成TXT文件，文件名是由Excel文件名和Sheet名組合而成的。
‘***********************************
Sub OutPutXlsToTxt()
Dim fs, myFile As Object
Dim i_row, i_col, i_MaxCol As Integer 'xls工作表的行列坐標變量和最大列數(shù)變量
Dim myfileline As String'txtfile的行數(shù)據(jù)
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的最大列數(shù)
If i_MaxCol = 0 Then '對沒有數(shù)據(jù)的表不做處理并退出程序
MsgBox "該表無數(shù)據(jù),不能導出!", 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))) + "," '生成每行數(shù)據(jù)
Next
myFile.writeline (Mid(myfileline, 1, Len(myfileline) - 1)) '將每行數(shù)據(jù)寫入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
