vba copy sheet 收藏
 Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks.open("源文件.xls") '先打開要復(fù)制的文件
wkbk.sheets(1).Copy thisworkbook.sheets(1) '再將此文件中第一個(gè)工作表復(fù)制到當(dāng)前工作簿的第一個(gè)工作表前
End Sub

這樣是最簡(jiǎn)單的代碼了，但是有些限制：如果工作表的某些單元格中字符數(shù)超過255個(gè)，則副本的該單元格中只保留前255個(gè)字符。

如果復(fù)制源文件中第一個(gè)工作表內(nèi)容到當(dāng)前工作簿第一個(gè)工作表中，用下列代碼：
Sub copySheet()
Dim wkbk As Workbook
Set wkbk = Workbooks("book2") '先打開要復(fù)制的文件
wkbk.Sheets(1).UsedRange.Copy '復(fù)制源文件中第一個(gè)工作表的內(nèi)容
ThisWorkbook.Sheets(1).Range("A1").Paste '粘貼到當(dāng)前工作簿第一個(gè)工作表中
End Sub

本人最近利用記錄宏的方式得到一條VBA語句以實(shí)現(xiàn)copy sheet 的功能. 語句如下:

Sheets("mainREPORT").Copy Before:=Sheets(4)

 

 

 

 

---------------------------------------------------------------------------------------------------------------

 

問題26：如何實(shí)現(xiàn)單元格在指定區(qū)域內(nèi)自動(dòng)跳轉(zhuǎn)?
例如，在單元格區(qū)域A1：C100中，無論何時(shí)在其中的某個(gè)單元格中輸入完一個(gè)單個(gè)的字符后，自動(dòng)按規(guī)律跳轉(zhuǎn)到下一單元格，即在單元格B1中輸完后，跳轉(zhuǎn)到單元格C1，在單元格C1中輸入完單個(gè)字符后，自動(dòng)跳轉(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：如何將多個(gè)工作簿中的工作表一次性合到一個(gè)工作簿里面？
解答：關(guān)于如何將多個(gè)工作簿（xls文件）中的工作表(worksheet）復(fù)制到同一個(gè)工作簿中的解決。下面的代碼可以將某個(gè)磁盤目錄下的多個(gè)xls文件的復(fù)制到含有這段代碼的xls文件中，而且xls文件可以根據(jù)處理worksheet的數(shù)量自動(dòng)的增加xls文件中worksheet的數(shù)量。使用時(shí)將代碼復(fù)制到xls文件的宏內(nèi)，然后運(yùn)行宏main即可。
代碼中運(yùn)用了filesystemobject對(duì)象和excel的range對(duì)象的copy方法以及worksheet和workbook對(duì)象的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         '默認(rèn)的worksheet數(shù)量是3,如果超過就自動(dòng)的增加
          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) '復(fù)制worksheet
        i_cnt = i_cnt + 1
        xlbook.Close             '關(guān)閉已經(jīng)打開的xls文件
      End If
    Next
    Set fl = Nothing           '關(guān)閉file,folder,filesystemobject對(duì)象
    Set fd = Nothing
    Set fs = Nothing
End Sub

Sub main()
  Dim sPath As String
  sPath = InputBox("請(qǐng)輸入目錄！如C:", "合并目錄下xls文件的sheet1")  '顯示輸入框獲取磁盤目錄
  If sPath = " " Then Exit Sub
  Mergesheet (sPath)
End Sub
‘***********************************
===================================================================
問題28：關(guān)于Excel單元格填充顏色......？
有五種可能的計(jì)算結(jié)果，比如結(jié)果會(huì)是1,2,3,4,5，不同的值給單元格填充不同顏色。條件格式最多只能定義三個(gè)條件，即只能填充最多三種顏色，不知用什么方法可以填上三種以上的顏色？
解答： 如果所有的結(jié)果集合只是在1，2，3，4，5中間，那么寫個(gè)宏就OK。
假設(shè)對(duì)于$B這一整列的情況如下：
B1=0或空時(shí)，單元格B1無填充顏色；
B1=1 時(shí)，給單元格B1填充紅色；
B1=2 時(shí)，給單元格B1填充藍(lán)色；
B1=3 時(shí)，給單元格B1填充綠色；
B1=4 時(shí)，給單元格B1填充黃色；
B1=5 時(shí)，給單元格B1填充紫色。
B2=0或空時(shí)，單元格B2無填充顏色；
B2=1 時(shí)，給單元格B2填充紅色；
B2=2 時(shí)，給單元格B2填充藍(lán)色；
B2=3 時(shí)，給單元格B2填充綠色；
B2=4 時(shí)，給單元格B2填充黃色；
B2=5 時(shí)，給單元格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
‘***********************************
---------------------------------------------------------------------
如果要做到單元格的值改變后填充的顏色自動(dòng)更新，這個(gè)宏該改成怎樣？
如果單元格的值是計(jì)算得來的，用 worksheet Calculate Event 應(yīng)該可以。
代碼：
‘***********************************
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
    '默認(rèn)值無填充色
    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
‘***********************************
( 如果單元格的值不是計(jì)算得來的，是直接輸入的，可以改用 Worksheet Change Event )
---------------------------------------------------------------------
還想問一下，這個(gè)宏的功能能否用自定義函數(shù)做到？
想用自定義函數(shù)的原因：?jiǎn)卧矜i定時(shí)，自定義函數(shù)依然可以正常運(yùn)行，而宏不行。
這個(gè)可以利用 UserInterfaceOnly ＝ TRUE 參數(shù)去解決。將 UserInterfaceOnly 參數(shù)設(shè)置為 True 可以允許通過代碼修改，但是不允許通過用戶界面修改。默認(rèn)值為 False，這意味著通過代碼和用戶界面項(xiàng)都不可以修改受保護(hù)的工作表。這個(gè)屬性設(shè)置只適用于當(dāng)前會(huì)話。如果您想讓代碼可以在任何會(huì)話中都可以操作工作表，那么您需要每次工作簿打開的時(shí)候添加設(shè)置這個(gè)屬性的代碼。
注意紅色那段字，由于這個(gè)原因，所以加一個(gè)宏在 workbook open event 讓每次開啟檔案時(shí)去設(shè)定UserInterfaceOnly 參數(shù)。
代碼；
‘***********************************
Private Sub Workbook_Open()
  '如果每個(gè)工作表都有不同的密碼
  Sheets(1).Protect Password:="secret1", UserInterFaceOnly:=True
  Sheets(2).Protect Password:="secret2", UserInterFaceOnly:=True
'按需要重復(fù)
'**如果所有工作表密碼相同
   'Dim wSheet As Worksheet
   'For Each wSheet In Worksheets
   '    wSheet.Protect Password:="secret", UserInterFaceOnly:=True
   'Next wSheet
'****
End Sub
‘***********************************
必須了解的一些相關(guān)概念(陳希章,微軟中文新聞組專家)
一般我們?cè)谥付伾珪r(shí)喜歡用ColorIndex這個(gè)屬性,通常情況下是沒有問題的。
但必須知道的一些概念是:ColorIndex是相對(duì)于調(diào)色盤中(調(diào)色盤有56中顏色)的某個(gè)位置的顏色,而調(diào)色盤是屬于工作簿級(jí)的對(duì)象,也就是說很有可能這樣一種情況就是,在這個(gè)工作簿中3代表紅色(假設(shè)),而到另一個(gè)工作簿中卻不是。
所以,如果要精確定義顏色,是不推薦用ColorIndex的,往往有些同志在調(diào)試程序時(shí)的疑惑也在于此(明明在自己電腦上是紅色,到用戶電腦上就不是了)。
還有兩種方法來返回顏色：
1.用Excel常量,如vbred,vbblue,vbgreen等。
2.用RGB函數(shù)。
用以上的方法,VBA語句也應(yīng)相應(yīng)更改。
例:Target.Offset(0, 1).Interior.ColorIndex = vColor 改成'Target.Offset(0, 1).Interior.Color = vbred 等等。
另從本例而言,建議統(tǒng)一用change事件。
===================================================================
問題29：如何實(shí)現(xiàn)在Sheet1中輸入后，在Sheet2中相應(yīng)的單元格中顯示？
即，如何實(shí)現(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ù)字每四行四行不停填充。
解答：
代碼說明，這個(gè)需求的關(guān)鍵是，需要建立sheet1的行列值與sheet2的行值之間的函數(shù)關(guān)系，綜合看就是一個(gè)代數(shù)系統(tǒng)內(nèi)的等差數(shù)列的關(guān)系。 這個(gè)代數(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 "輸錯(cuò)了位置", vbCritical '這里是錯(cuò)誤的提示信息
    Exit Sub                         '退出代碼的執(zhí)行
    End If
   '按照sheet1與sheet2行列的特定算法填充數(shù)據(jù)
   Sheet2.Cells((Target.Row - 1) * 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
問題30：如何實(shí)現(xiàn)當(dāng)某一單元格滿足非空條件時(shí)，輸入的數(shù)據(jù)不能修改？
如果在excel中寫如此要求的一個(gè)函數(shù)：某一單元格滿足非空條件時(shí)，輸入的數(shù)據(jù)不能修改。就是當(dāng)我往一個(gè)單元格內(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方法導(dǎo)出Xls文件至Txt文件？
即如何以一定的格式輸出Excel文件的數(shù)據(jù)。
解答：
這是個(gè)常見的問題，因?yàn)樵S多不同應(yīng)用系統(tǒng)之間報(bào)送數(shù)據(jù)時(shí)，最好的方法就是報(bào)送統(tǒng)一格式的數(shù)據(jù)文件，而帶有特殊分割符號(hào)的文本文件應(yīng)該說是最適用的。
下面的代碼將輸出的文件改為“文件名”+“Worksheet名”組合的TXT文件。代碼的適當(dāng)說明：生成Txt文件需要使用FileSystemObject對(duì)象，關(guān)于該對(duì)象的說明，可以參閱msdn或vba幫助中的相關(guān)內(nèi)容。這段程序可以在將xls文件中任意的sheet中的內(nèi)容導(dǎo)出成txt文本文件。
如下就是代碼?？梢詫⑵鋸?fù)制到任何一個(gè)xls文件中。使用時(shí)，只要打開某個(gè)sheet，然后運(yùn)行這個(gè)宏（菜單內(nèi)：工具-〉宏-〉運(yùn)行宏OutPutXlsToTxt），即可將該sheet內(nèi)的數(shù)據(jù)導(dǎo)出生成TXT文件，文件名是由Excel文件名和Sheet名組合而成的。
‘***********************************
Sub OutPutXlsToTxt()
  Dim fs, myFile As Object
  Dim i_row, i_col, i_MaxCol As Integer 'xls工作表的行列坐標(biāo)變量和最大列數(shù)變量
  Dim myfileline As String'txtfile的行數(shù)據(jù)
 
  Set fs = CreateObject("Scripting.FileSystemObject")  '建立filesytemobject
 '通過filesystemobject新建一個(gè)和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    '獲得整個(gè)sheet的最大列數(shù)
  If i_MaxCol = 0 Then       '對(duì)沒有數(shù)據(jù)的表不做處理并退出程序
    MsgBox "該表無數(shù)據(jù),不能導(dǎo)出!", 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                   '關(guān)閉文件和filesystemobject對(duì)象

-------------------------------------------------------------------------------------------------------------------------------------------------

 

 

 

 

 

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

 

本文來自CSDN博客，轉(zhuǎn)載請(qǐng)標(biāo)明出處：http://blog.csdn.net/zhanghao0722/archive/2008/09/10/2910958.aspx