麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 請問有人能幫忙解答嗎?函數公式該如何寫呢? [打印本頁]

作者: alltest 時間: 2012-12-19 09:47 標題: 請問有人能幫忙解答嗎?函數公式該如何寫呢?

請問有人能幫忙解答嗎?函數公式該如何寫呢?
(不要用複製貼上) 因為有上千筆資料近百各sheet

因為我現在只能用複製貼上,可是要花很多時間找與貼

能讓book2 裡的sheet1自動抓到book1 AA項目及其後面某欄位資料
            sheet2自動抓到book1 BB項目及其後面某欄位資料
            sheet3...........book1 CC.....................

我只要打開檔案book2 就會自動抓取檔案book1資料自動分類AA BB CC到不同sheet

因為檔案book1裡的sheet1 AA BB CC  數目每個月會有所變動
(book1是我的來源案檔)
(book2是我想要的結果)

檔案book1 sheet1
   A       B       C       D
1 AA       10       11       111
2 AA       20       22       222
3 AA       30       33       333
4 AA       40       44       444
5 BB       50       55       555
6 BB       60       66       666
7 CC       70       77       777
8 CC       80       88       888
9 CC       90       99       999
10 CC    100    11       111
11 CC    110    22       222
12 CC    120    33       333
13 CC    130    44       444
14 CC    140    55       555
15 CC    150    66       666

檔案book2 sheet2
   A       B       D
1 BB       50       555
2 BB       60       666

檔案book2 sheet1
   A       C       D
1 AA       11       111
2 AA       22       222
3 AA       33       333
4 AA       44       444

作者: p212 時間: 2012-12-19 13:40

回復 1# alltest
1、依吾人拙見，您的資料在未編碼與一對多狀況下(如AA對應多筆資料)，無法單就函數解決問題。若對raw data_即您所說的檔案book1 sheet1內資料進行編碼，使呈現一對一之狀況，則用VLOOKUP即可解決您的問題。
2、以VBA或許可以解決，不過這就有請VBA高手了。

作者: Hsieh 時間: 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

複製代碼

作者: alltest 時間: 2012-12-23 16:01

回復 4# Hsieh

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

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

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

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

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

[attach]13666[/attach][attach]13667[/attach]

作者: alltest 時間: 2012-12-24 22:23 標題: 請問有高手願意幫忙解答嗎? ~ 感謝大大^^ (自動抓取分類)

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

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

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

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

[attach]13671[/attach]
[attach]13672[/attach]
[attach]13673[/attach]

作者: Hsieh 時間: 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

複製代碼

作者: GBKEE 時間: 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

複製代碼

作者: alltest 時間: 2012-12-25 21:56

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

回復 7# Hsieh

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

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

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

作者: alltest 時間: 2012-12-25 22:23

回復 8# GBKEE

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

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

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

作者: GBKEE 時間: 2012-12-26 06:48

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

作者: alltest 時間: 2012-12-26 22:46

回復 11# GBKEE

回報版主 GBKEE大大

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

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

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

作者: GBKEE 時間: 2012-12-27 06:55

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

作者: alltest 時間: 2012-12-27 22:23

回復 13# GBKEE

報告:版主大大~

      EX1  放在 book1 執行後只出現前四項欄位

      附上book1 & book2 壓縮檔,供版主大大參考

      再次謝謝版主 GBKEE大大的熱心幫忙~感恩^^

         [attach]13712[/attach]

作者: GBKEE 時間: 2012-12-28 07:57

本帖最後由 GBKEE 於 2012-12-28 07:59 編輯

回復 14# alltest
EX 放在 book1 會出現錯誤訊息       book2 會出現錯誤訊息
如圖 :  book2 工作表名稱錯誤

[attach]13716[/attach]


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

如圖 book1 請新增一工作表命名為 : "表頭"

[attach]13717[/attach]

修改 Sub Ex1() 如下

Sub Ex1() '新增活頁簿
Dim E As Variant, r As Integer, xi As Integer, xC As Integer
Dim Rng(1 To 2), Wb As Workbook
Set Wb = Workbooks.Add(1) '新增活頁簿
With Workbooks("book1.xls").Sheets("異常明細")
.AutoFilterMode = False
xC = .Cells(1, .Columns.Count).End(xlToLeft).Column
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 xC Step 3
Set Rng(1) = .Range("b3:d" & xi)
Set Rng(2) = .Range(.Cells(3, r).Resize(, IIf(r < xC - 1, 3, 2)).Address & ":" & .Cells(xi, r + IIf(r < xC - 1, 2, 1)).Address)
Set Rng(1) = Union(Rng(1), Rng(2))
Wb.Sheets.Add(, Sheets(Sheets.Count)).Name = E & "-" & .Cells(1, r) '新增工作表:命名
With ActiveSheet
If r < xC - 1 Then
Workbooks("book1.xls").Sheets("表頭").[A1].CurrentRegion.Copy .[A1]
'book1 請新增一工作表命名為 : "表頭"
Else
Workbooks("book1.xls").Sheets("表頭").[A4].CurrentRegion.Copy .[A1]
End If
Rng(1).Copy ActiveSheet.[A3]
End With
Next
Next
.AutoFilterMode = False
End With
Wb.Sheets(1).Move After:=Wb.Sheets(Wb.Sheets.Count)
Wb.Sheets(1).Activate
End Sub

複製代碼

作者: alltest 時間: 2012-12-28 12:03

回復 15# GBKEE

報告版主大大: EX 已經測試OK~非常感激^^ (版主真是太強了~)
另外,EX1 我還是是不出來說,也經按照版主大大的指示修改
還是是不出來耶~

煩請版主大大,再熱心幫忙看看我那兒做做錯了呢?~謝謝您

附上修改後的檔案如下:

[attach]13718[/attach]

作者: alltest 時間: 2012-12-28 12:10

回復 15# GBKEE

不好意思,不小心把版主大大的關心取消了( 按錯了,sorry ..... ^^~ )
還請版主大大多多觀照一下~感激~感恩!

作者: c_c_lai 時間: 2012-12-28 12:24

回復 16# alltest
回復 15# GBKEE

xi = .Cells(Rows.Count, 2).End(xlUp).Row

複製代碼

修改成：

xi = .Cells(.Rows.Count, 2).End(xlUp).Row

複製代碼

便 OK 了！
( Rows.Count ----> .Rows.Count )

作者: GBKEE 時間: 2012-12-28 13:21

回復 18# c_c_lai
便 OK 了！ ( Rows.Count ----> .Rows.Count )
使用2003(老版本)忘記了,2007版(含)以上 Rows.Count , 必需如此 . .Rows.Count

作者: alltest 時間: 2012-12-28 23:18

回復 18# c_c_lai

謝謝您的熱心解答~
不好意思我的是2002老版本
還是無法執行
執行後如下
[attach]13725[/attach]

作者: alltest 時間: 2012-12-28 23:21

回復 19# GBKEE

謝謝版主大大的熱心回覆~
不過,不好意思~
我的是2002老版本
還是無法執行
執行後如下
[attach]13726[/attach]

作者: alltest 時間: 2012-12-29 00:12

回復 19# GBKEE

再次謝謝版主大大的解答~

sorry~剛剛是我一點小小的疏忽

您修改的EX1已經執行OK~

非常完美,比我想要的還要好,還要周到

  真不愧是版主大大~

謝謝您,先祝您新年快樂^^

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