fangsc

中學生 Rank: 2

帖子: 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

fangsc

中學生 Rank: 2

帖子: 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

freeffly

高中生 Rank: 3 Rank: 3

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

熱烈參與勳章好學求知勳章

6^#

發表於 2012-12-12 16:28 | 只看該作者

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

字典兩各字還真難理解

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 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

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 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
可用工作表自動篩選

Option Explicit
Sub Ex()
Dim Sh As Worksheet
'Dim 宣告變數
For Each Sh In Sheets
'For 迴圈: 工作表物件集合(此活頁簿)中, 依序處裡工作表
If Sh.Name <> "Sheet1" Then
'活頁簿工作表的名稱不是要複製資料的工作表
With Sheets("Sheet1")
'在要複製資料的工作表(物件中)
.AutoFilterMode = False
'取消此工作表自動篩選
.Range("A1").AutoFilter 3, Sh.Name
'工作表A1的連續範圍為自動篩選的範圍,連續範圍的第3欄為準則:= Sh工作表的名稱
.UsedRange.Copy Sh.[A1]
'複製Sheets("Sheet1") 到Sh工作表
End With
'結束(物件中)
End If
'結束(If Sh.Name <> "Sheet1" Then)
Next
'回到對應的 For 迴圈直到處裡完畢
Sheets("Sheet1").AutoFilterMode = False
'Sheets("Sheet1")工作表取消自動篩選
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2012-12-10 21:41 | 只看該作者

回復 1# fangsc

Sub ex()
Set d = CreateObject("Scripting.Dictionary")
With Sheet1
For Each a In .Range(.[C2], .[C2].End(xlDown))
If d.exists(a.Value) = False Then
d(a.Value) = a.Address
Else
d(a.Value) = d(a.Value) & "," & a.Address
End If
Next
For Each ky In d.keys
Sheets(ky).UsedRange.Offset(1).ClearContents
.Range(d(ky)).EntireRow.Copy Sheets(ky).[A2]
Next
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP

stillfish00

大學生 Rank: 4

帖子: 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事件內去處理

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim r As Long
Dim sales As String
Application.ScreenUpdating = False
'clear header
For Each ws In Sheets
If not ws is Me Then
ws.UsedRange.Offset(1).ClearContents
End If
Next
For r = 2 To Range("C" & Rows.Count).End(xlUp).Row
sales = Cells(r, "C").Value
If sales <> "" Then
If Not hasSheet(sales) Then
With Sheets.Add(After:=Sheets(Sheets.Count))
.name = sales
[A1:H1].Copy .[A1]
End With
End If
With Sheets(sales)
.Range("C" & .Rows.Count).End(xlUp).Offset(1, -2).Resize(1, 8) = Range("A" & r & ":" & "H" & r).Value
End With
End If
Next r
Me.Select
Application.ScreenUpdating = True
End Sub
Function hasSheet(name As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(name)
On Error GoTo 0
If ws Is Nothing Then
hasSheet = False
Else
hasSheet = True
End If
Set ws = Nothing
End Function

複製代碼

TOP