將資料複製到不同的工作表

fangsc

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

stillfish00

回復 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
    
36. 
    
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

回復 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

回復 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

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

freeffly

這各自動篩選的方式挺簡潔
又見識到不同方式
字典也是好方式
還在學習中

fangsc

回復 4# GBKEE

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