請問有人能幫忙解答嗎?函數公式該如何寫呢? - Excel程式區

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兔年全勤獎章

12^# 跳轉到 »

發表於 2012-12-27 06:55 | 只看該作者

回復 12# alltest
EX 放在 book1 會出現錯誤訊息 book2 會出現錯誤訊息
你的 book1,book2 上傳看看.
EX1 放在 book1 可以執行，但出現的結果怪怪的說~
如何怪怪, 請說看看.

TOP

alltest

中學生 Rank: 2

帖子: 40
主題: 9
精華: 0
積分: 70
點名: 0
作業系統: windows xp
軟體版本: office xp
閱讀權限: 20
註冊時間: 2012-12-17
最後登錄: 2013-1-28

11^#

發表於 2012-12-26 22:46 | 只看該作者

回復 11# GBKEE

回報版主 GBKEE大大

EX 放在 book1 會出現錯誤訊息
      book2 會出現錯誤訊息

EX1  放在 book1 可以執行，但出現的結果怪怪的說~

謝謝~ 版主 GBKEE大大的熱心回覆^^

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兔年全勤獎章

10^#

發表於 2012-12-26 06:48 | 只看該作者

回復 10# alltest
Ex 放哪裡都可以
Ex1 (新增活頁簿)需放在book1.xls 或以存檔的活頁簿中

TOP

alltest

中學生 Rank: 2

帖子: 40
主題: 9
精華: 0
積分: 70
點名: 0
作業系統: windows xp
軟體版本: office xp
閱讀權限: 20
註冊時間: 2012-12-17
最後登錄: 2013-1-28

9^#

發表於 2012-12-25 22:23 | 只看該作者

回復 8# GBKEE

謝謝您~ 版主 GBKEE大大的熱心幫忙解答( 非常感謝)...*^_^*

不好意思~(因為我不會VB/VBA~sorry!!)
所以想請問版主 GBKEE大大~

我應該把程式放在book1 或者是 book2
是分成2個模組或是放在同一個模組
然後執行巨集呢?

TOP

alltest

中學生 Rank: 2

帖子: 40
主題: 9
精華: 0
積分: 70
點名: 0
作業系統: windows xp
軟體版本: office xp
閱讀權限: 20
註冊時間: 2012-12-17
最後登錄: 2013-1-28

8^#

發表於 2012-12-25 21:56 | 只看該作者

本帖最後由 alltest 於 2012-12-25 21:57 編輯

回復 7# Hsieh

謝謝您~超級版主 Hsieh大大的熱心幫忙 *^_^*

跟我想要的一模一樣耶.....YA!~

(您真的好強喔!~再次謝謝您~~)

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兔年全勤獎章

7^#

發表於 2012-12-25 12:45 | 只看該作者

回復 6# alltest
自動篩選:

Sub Ex()
Dim E As Variant, r As Integer, xi As Integer
Dim Rng(1 To 2)
With Workbooks("book1.xls").Sheets("異常明細")
.AutoFilterMode = False
For Each E In Array("黃色", "紅色", "青色")
.Range("A2", .UsedRange.SpecialCells(xlCellTypeLastCell).Address).AutoFilter Field:=2, Criteria1:=E
xi = .Cells(Rows.Count, 2).End(xlUp).Row
For r = 5 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 3
Set Rng(1) = .Range("b1:d" & xi)
Set Rng(2) = .Range(.Cells(1, r).Resize(, 3).Address & ":" & .Cells(xi, r + 2).Address)
Set Rng(1) = Union(Rng(1), Rng(2))
With Workbooks("book2.xls").Sheets(E & "-" & .Cells(1, r))
.Cells.Clear
Rng(1).Copy .[A1]
End With
Next
Next
.AutoFilterMode = False
End With
End Sub

複製代碼

Sub Ex1() '新增活頁簿
Dim E As Variant, r As Integer, xi As Integer
Dim Rng(1 To 2), Wb As Workbook
Set Wb = Workbooks.Add(1) '新增活頁簿
With Workbooks("book1.xls").Sheets("異常明細")
.AutoFilterMode = False
For Each E In Array("黃色", "紅色", "青色")
.Range("A2", .UsedRange.SpecialCells(xlCellTypeLastCell).Address).AutoFilter Field:=2, Criteria1:=E
xi = .Cells(Rows.Count, 2).End(xlUp).Row
For r = 5 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 3
Set Rng(1) = .Range("b1:d" & xi)
Set Rng(2) = .Range(.Cells(1, r).Resize(, 3).Address & ":" & .Cells(xi, r + 2).Address)
Set Rng(1) = Union(Rng(1), Rng(2))
Wb.Sheets.Add(, Sheets(Sheets.Count)).Name = E & "-" & .Cells(1, r) '新增工作表:命名
Rng(1).Copy ActiveSheet.[A1]
Next
Next
.AutoFilterMode = False
End With
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

6^#

發表於 2012-12-24 23:13 | 只看該作者

回復 6# alltest
試試看
book2的一般模組

Sub Auto_Open()
Dim ary(), fs$, Sh As Worksheet
Dim ay(1), Ar, Ky, s&
Set d = CreateObject("Scripting.Dictionary")
fs = ThisWorkbook.Path & "\book1.xls"
With Workbooks.Open(fs)
With .Sheets(1)
For Each A In .Range(.[B3], .[B3].End(xlDown))
r = A.Row
For Each b In .Range(.[E1], .[IV1].End(xlToLeft).Offset(, -1)).SpecialCells(xlCellTypeConstants)
k = b.Column
Ar = Array(.Cells(r, 2).Value, .Cells(r, 3).Value, .Cells(r, 4).Value, .Cells(r, k).Value, .Cells(r, k + 1).Value, .Cells(r, k + 2).Value)
If IsEmpty(d(A & "-" & b)) Then
ay(0) = Ar
d(A & "-" & b) = ay
Else
ary = d(A & "-" & b)
s = UBound(ary)
ReDim Preserve ary(s + 1)
ary(s) = Ar
d(A & "-" & b) = ary
End If
Next
Next
End With
For Each Sh In ThisWorkbook.Sheets
With Sh
.UsedRange.Offset(2) = ""
Ky = .Name
If IsArray(d(Ky)) Then
ary = d(Ky)
For i = 0 To UBound(ary) - 1
.Cells(3 + i, 1).Resize(, UBound(Ar) + 1) = ary(i)
Next
End If
End With
Next
.Close 0
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP

alltest

中學生 Rank: 2

帖子: 40
主題: 9
精華: 0
積分: 70
點名: 0
作業系統: windows xp
軟體版本: office xp
閱讀權限: 20
註冊時間: 2012-12-17
最後登錄: 2013-1-28

5^#

發表於 2012-12-24 22:23 | 只看該作者

請問有高手願意幫忙解答嗎? ~ 感謝大大^^ (自動抓取分類)

本帖最後由 alltest 於 2012-12-24 22:25 編輯

book1是我的來源檔
book2是我想要的

book1裡的分類數量每月會變動而有所不同

我想只要打開book2就會自動抓取book1裡的資料自動分類
例如:book2裡的(sheet) 黃色-A部門 / 黃色-B部門 (後面依此類推)

book.rar (21.58 KB)

TOP

alltest

中學生 Rank: 2

帖子: 40
主題: 9
精華: 0
積分: 70
點名: 0
作業系統: windows xp
軟體版本: office xp
閱讀權限: 20
註冊時間: 2012-12-17
最後登錄: 2013-1-28

4^#

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

回復 4# Hsieh

非常謝謝您~超級版主Hsieh大大的幫忙
(非常利害! 一次到位,完全與我想要的一樣)
此問題已經解決~感激不進^^

有榮幸可以請超級版主Hsieh大大再幫一下忙嗎?
問題與此發問很類似,但更複雜些

book1是我的來源檔
book2是我想要的

book1裡的分類數量每月會變動而有所不同

我想只要打開book2就會自動抓取book1裡的資料自動分類
例如:book2裡的(sheet) 黃色-A部門 / 黃色-B部門 (後面依此類推)

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

3^#

發表於 2012-12-22 22:30 | 只看該作者

回復 3# alltest
Book1的一般模組

Sub Split_Data()
Set d = CreateObject("Scripting.Dictionary")
With ThisWorkbook
With .Sheets(1)
For Each a In .Range(.[A1], .[A1].End(xlDown))
If IsEmpty(d(a & "")) Then
Set d(a & "") = a.Resize(, 4)
Else
Set d(a & "") = Union(d(a & ""), a.Resize(, 4))
End If
Next
For Each ky In d.keys
Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
d(ky).Copy sh.[A1]
sh.Name = ky
Next
End With
.Sheets(d.keys).Move
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP

[發問] 請問有人能幫忙解答嗎?函數公式該如何寫呢?

請問有高手願意幫忙解答嗎? ~ 感謝大大^^ (自動抓取分類)

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]