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

alltest

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

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

Hsieh

回復 3# alltest
Book1的一般模組

1. Sub Split_Data()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With ThisWorkbook
   
4.    With .Sheets(1)
   
5.       For Each a In .Range(.[A1], .[A1].End(xlDown))
   
6.          If IsEmpty(d(a & "")) Then
   
7.             Set d(a & "") = a.Resize(, 4)
   
8.          Else
   
9.             Set d(a & "") = Union(d(a & ""), a.Resize(, 4))
   
10.          End If
    
11.       Next
    
12.       For Each ky In d.keys
    
13.          Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
    
14.          d(ky).Copy sh.[A1]
    
15.          sh.Name = ky
    
16.       Next
    
17.     End With
    
18.    .Sheets(d.keys).Move
    
19. End With
    
20.      
    
21. End Sub

複製代碼

alltest

回復 4# Hsieh


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

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

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

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

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

下載 (341.02 KB)

2012-12-23 15:59

下載 (186.69 KB)

2012-12-23 16:00

alltest

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

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

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

下載 (341.02 KB)

2012-12-24 22:18

下載 (186.69 KB)

2012-12-24 22:19

book.rar (21.58 KB)

下載次數: 12

2012-12-24 22:19

Hsieh

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

1. Sub Auto_Open()
   
2. Dim ary(), fs$, Sh As Worksheet
   
3. Dim ay(1), Ar, Ky, s&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. fs = ThisWorkbook.Path & "\book1.xls"
   
6. With Workbooks.Open(fs)
   
7.    With .Sheets(1)
   
8.       For Each A In .Range(.[B3], .[B3].End(xlDown))
   
9.       r = A.Row
   
10.          For Each b In .Range(.[E1], .[IV1].End(xlToLeft).Offset(, -1)).SpecialCells(xlCellTypeConstants)
    
11.          k = b.Column
    
12.          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)
    
13.          If IsEmpty(d(A & "-" & b)) Then
    
14.             ay(0) = Ar
    
15.             d(A & "-" & b) = ay
    
16.             Else
    
17.             ary = d(A & "-" & b)
    
18.             s = UBound(ary)
    
19.             ReDim Preserve ary(s + 1)
    
20.             ary(s) = Ar
    
21.             d(A & "-" & b) = ary
    
22.          End If
    
23.          Next
    
24.         Next
    
25.      End With
    
26. For Each Sh In ThisWorkbook.Sheets
    
27.     With Sh
    
28.        .UsedRange.Offset(2) = ""
    
29.        Ky = .Name
    
30.        If IsArray(d(Ky)) Then
    
31.        ary = d(Ky)
    
32.        For i = 0 To UBound(ary) - 1
    
33.          .Cells(3 + i, 1).Resize(, UBound(Ar) + 1) = ary(i)
    
34.        Next
    
35.        End If
    
36.     End With
    
37. Next
    
38.      .Close 0
    
39. End With
    
40. End Sub

複製代碼

GBKEE

回復 6# alltest
自動篩選:

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

複製代碼

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

複製代碼

alltest

回復 7# Hsieh


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

   跟我想要的一模一樣耶.....YA!~
   
  (您真的好強喔!~再次謝謝您~~)

alltest

回復 8# GBKEE


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

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

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

GBKEE

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