Board logo

標題: 將資料複製到不同的工作表 [打印本頁]
作者: fangsc    時間: 2012-12-5 21:14     標題: 將資料複製到不同的工作表

附件sheet1是所有的資料工作表,
當資料有異動時,將其他工作表的資料清空 (資料抬頭不清除), 再將sheet1的資料依不同的Sales複製到相對應的工作表裡.
請教VBA程式如何寫?
感謝...
作者: stillfish00    時間: 2012-12-10 20:17

本帖最後由 stillfish00 於 2012-12-10 20:20 編輯

回復 1# fangsc
參考看看下面程式 , 但其實資料量若是很大的話不是很建議直接在Worksheet_Change事件內去處理
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim ws As Worksheet
  4.     Dim r As Long
  5.     Dim sales As String
  6.                
  7.     Application.ScreenUpdating = False
  8.    
  9.     'clear header
  10.     For Each ws In Sheets
  11.         If not ws is Me Then
  12.             ws.UsedRange.Offset(1).ClearContents
  13.         End If
  14.     Next
  15.    
  16.     For r = 2 To Range("C" & Rows.Count).End(xlUp).Row
  17.         sales = Cells(r, "C").Value
  18.         
  19.         If sales <> "" Then
  20.             If Not hasSheet(sales) Then
  21.                 With Sheets.Add(After:=Sheets(Sheets.Count))
  22.                     .name = sales
  23.                     [A1:H1].Copy .[A1]
  24.                 End With
  25.             End If
  26.             
  27.             With Sheets(sales)
  28.                 .Range("C" & .Rows.Count).End(xlUp).Offset(1, -2).Resize(1, 8) = Range("A" & r & ":" & "H" & r).Value
  29.             End With
  30.         End If
  31.     Next r
  32.    
  33.     Me.Select
  34.     Application.ScreenUpdating = True
  35. End Sub

  37. Function hasSheet(name As String) As Boolean
  38.     Dim ws As Worksheet
  39.    
  40.     On Error Resume Next
  41.     Set ws = Sheets(name)
  42.     On Error GoTo 0
  43.    
  44.     If ws Is Nothing Then
  45.         hasSheet = False
  46.     Else
  47.         hasSheet = True
  48.     End If
  49.    
  50.     Set ws = Nothing
  51. End Function
複製代碼
作者: Hsieh    時間: 2012-12-10 21:41

回復 1# fangsc
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheet1
  4.   For Each a In .Range(.[C2], .[C2].End(xlDown))
  5.     If d.exists(a.Value) = False Then
  6.        d(a.Value) = a.Address
  7.        Else
  8.        d(a.Value) = d(a.Value) & "," & a.Address
  9.     End If
  10.   Next
  11. For Each ky In d.keys
  12.    Sheets(ky).UsedRange.Offset(1).ClearContents
  13.   .Range(d(ky)).EntireRow.Copy Sheets(ky).[A2]
  14. Next
  15. End With
  16. End Sub
複製代碼
作者: GBKEE    時間: 2012-12-11 08:07

本帖最後由 GBKEE 於 2012-12-11 08:33 編輯

回復 1# fangsc
可用工作表自動篩選
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Sh As Worksheet
  4.     'Dim 宣告變數
  5.     For Each Sh In Sheets
  6.     'For 迴圈: 工作表物件集合(此活頁簿)中, 依序處裡工作表
  7.         If Sh.Name <> "Sheet1" Then
  8.         '活頁簿工作表的名稱 不是要複製資料的工作表
  9.             With Sheets("Sheet1")
  10.             '在要複製資料的工作表(物件中)
  11.                 .AutoFilterMode = False
  12.                 '取消此工作表自動篩選
  13.                 .Range("A1").AutoFilter 3, Sh.Name
  14.                 '工作表A1的連續範圍為自動篩選的範圍,連續範圍的第3欄為準則:= Sh工作表的名稱
  15.               .UsedRange.Copy Sh.[A1]
  16.                 '複製Sheets("Sheet1") 到Sh工作表
  17.             End With
  18.             '結束(物件中)
  19.         End If
  20.         '結束(If Sh.Name <> "Sheet1" Then)
  21.     Next
  22.     '回到對應的 For 迴圈 直到處裡完畢
  23.     Sheets("Sheet1").AutoFilterMode = False
  24.     'Sheets("Sheet1")工作表取消自動篩選
  25. End Sub
複製代碼
作者: c_c_lai    時間: 2012-12-11 20:28

Hsieh 版大的資料字典 ("Scripting.Dictionary")、
以及 GBKEE  版大的工作表自動篩選 (AutoFilter)，
對於"處理將資料複製到不同的工作表"的處理過程
都各有其特色，是個蠻值得參考的資料，謝謝！
作者: freeffly    時間: 2012-12-12 16:28

這各自動篩選的方式挺簡潔
又見識到不同方式
字典也是好方式
還在學習中
作者: fangsc    時間: 2012-12-20 21:05

回復 4# GBKEE

感謝Stillfish00, 超級版主及GBKEE版主,因為最近工作實在太忙,沒有時間進來看各位的指導.
應該也是沒有把Excel函數及VBA學精,工作上才無法做到事半功倍吧!
程式收下了,盡力研究一下. 感恩!!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)