返回列表 上一主題 發帖

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

fangsc

帖子
81 
主題
27 
精華
0 
積分
151 
點名
0  
作業系統
win7 
軟體版本
office2007 
閱讀權限
20 
性別
女 
來自
Taiwan 
註冊時間
2012-6-7 
最後登錄
2020-11-27 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-12-5 21:14 | 只看該作者

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

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

ABC.rar (4.24 KB)

收藏 分享
fangac

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 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
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
91  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-19 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 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
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
5#
發表於 2012-12-11 20:28 | 只看該作者
Hsieh 版大的資料字典 ("Scripting.Dictionary")、
以及 GBKEE  版大的工作表自動篩選 (AutoFilter)，
對於"處理將資料複製到不同的工作表"的處理過程
都各有其特色，是個蠻值得參考的資料，謝謝！

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
6#
發表於 2012-12-12 16:28 | 只看該作者
這各自動篩選的方式挺簡潔
又見識到不同方式
字典也是好方式
還在學習中
字典兩各字 還真難理解

TOP

fangsc

帖子
81 
主題
27 
精華
0 
積分
151 
點名
0  
作業系統
win7 
軟體版本
office2007 
閱讀權限
20 
性別
女 
來自
Taiwan 
註冊時間
2012-6-7 
最後登錄
2020-11-27 

論壇贊助勳章
7#
發表於 2012-12-20 21:05 | 只看該作者
回復 4# GBKEE

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

TOP

        靜思自在 : 生氣，就是拿別人的過錯來懲罰自己。
返回列表 上一主題