Board logo

標題: [發問] 想請教VBA高手兩SHEETS比較後找出特定之儲存格再貼入特定位置中 [打印本頁]
作者: YUPOYU    時間: 2012-3-31 23:22     標題: 想請教VBA高手兩SHEETS比較後找出特定之儲存格再貼入特定位置中

本帖最後由 YUPOYU 於 2012-4-2 12:14 編輯

SHEET1如下
         A          B                  C                   D                 E                  F                    G                 H                  I                     J                    K
  1     a1        1        1        3        4        101        102        7        8        9        10
  2    a2        11        12        13        14        15        16        17        18        19        20
  3      a3        21        22        23        24        5        26        27        28        29        30
  4      a4        31        32        33        34        35        36        37        38        39        40
  5     a5        41        42        4        44        45        46        47        48        49        50
  6     a6        51        52        53        54        55        56        57        58        59        60
  7     a7        61        62        63        64        6        66        67        68        69        70
  8     a8        71        72        73        74        75        76        77        78        79        80
  9     a9        81        82        83        84        85        86        87        88        89        90
10   a10        1        92        93        94        95        96        97        98        99        100
SHEET2如下
           A            B               C                   D                  E                   F                   G                   H                 I                     J
1        1             2        3        4        5        6        7        8        9        10

1.請問一下VBA之高手們可否教教小女子如何用VBA程式,以SHEEET2之A1   B1   C1   D1   E1   F1   G1   H1   I1   J1 儲存格的各別值為個別依據去各別
比對SHEEET1之B1:K10儲存格的每一個值(實際範圍情況為B2:V4000,若用人工或函數比對可能不是比對死就是檔案很大跑不太動,救命阿!),
若有相同值,才傳回相對應之SHEEET1 A欄之值(若沒有則略過,繼續比對下一個儲存格)
至 SHEET2之A2  A3 A4.........依序排下去,SHEET2想要的結果如下:
           A            B               C                   D                  E                   F                   G                   H                 I                     J
1        1             2        3        4        5        6        7        8        9        10
2        a1
3       a10
4       a1
5      a1
6       a1
7      a5
8     a1
9.    a3
10  a7
11 a1
依篩選結果繼續往下排列......

2.且也想問SHEET2之A2  A3   A4.........內的值不知可否再自動由小到大排序

請VBA之高手們幫幫忙,救救小女子我呀!
感激不盡喔!
                                         yupopo 留

[attach]10262[/attach][attach]10262[/attach]
上面為附件檔案,請各位vba高手大大們幫忙看一下
(真不好意思,沒把版面排好,造成大大們的困擾!請見諒)
                                 
                                              yupopo 留
作者: Hsieh    時間: 2012-4-1 11:52

回復 1# YUPOYU
不是很懂你的意思，先試試看
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheet1
  4. For j = 2 To .[IV1].End(xlToLeft).Column
  5.     For i = 1 To .[A65536].End(xlUp).Row
  6.       If d(.Cells(i, j).Value) = "" Then
  7.       d(.Cells(i, j).Value) = .Cells(i, 1)
  8.       Else
  9.       d(.Cells(i, j).Value) = d(.Cells(i, j).Value) & "," & .Cells(i, 1)
  10.       End If
  11.     Next
  12. Next
  13. End With
  14. With Sheet2
  15.   For Each a In .Range(.[A1], .[IV1].End(xlToLeft))
  16.   If d(a.Value) <> "" Then
  17.     ar = Split(d(a.Value), ",")
  18.     With a.Offset(1).Resize(UBound(ar) + 1, 1)
  19.     .Value = Application.Transpose(ar)
  20.     .Sort key1:=.Cells(1), Header:=xlYes
  21.     End With
  22.   End If
  23.   Next
  24. End With
  25. End Sub
複製代碼
作者: YUPOYU    時間: 2012-4-2 12:27

回復 2# Hsieh


    感謝版主熱心為我解答,我有把代碼試試看,結果是對的,但排列方式好像沒有符合我想要的版面,
我想是我陳述的不夠清楚明瞭,真的很抱歉,
我想表達的自動核對過程,得到結果及顯示結果的方式
我再仔細想想應該如下所述
1.自動核對過程,得到結果
自動先選取SHEET2的A1,得知其值為1
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為1,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,得到值 a1及 a10
比對 C1:C10後,得到值 a1
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的B1,得知其值為2
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為2,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的C1,得知其值為3
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為3,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,得到值 a1
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的D1,得知其值為4
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為4,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,得到值 a1
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的E1,得知其值為5
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為5,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,得到值 a3
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的F1,得知其值為6
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為6,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,得到值 a7
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的G1,得知其值為7
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為7,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,得到值 a1
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的H1,得知其值為8
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為8,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,得到值 a1
比對 J1:J10後,無值顯現
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的I1,得知其值為9
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為9,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,得到值 a1
比對 K1:K10後,無值顯現

接著再自動先選取SHEET2的J1,得知其值為10
然後去依序自動比對SHEET1 之B1:B10, C1:C10, D1:D10, E1:E10, F1:F10, G1:G10, H1:H10, I1:I10, J1:J10, K1:K10
若符合值為10,則抓出相對應A欄列位之值
結果應如下
比對 B1:B10後,無值顯現
比對 C1:C10後,無值顯現
比對 D1:D10後,無值顯現
比對 E1:E10後,無值顯現
比對 F1:F10後,無值顯現
比對 G1:G10後,無值顯現
比對 H1:H10後,無值顯現
比對 I1:I10後,無值顯現
比對 J1:J10後,無值顯現
比對 K1:K10後,得到值 a1

2.顯示結果的方式
依上述依序得到的12個結果值再依序存入SHEET2 A2 A3 A4........之儲存格中(因為A1列中已有數值,所以A2為啟始點)
結果如下
SHEET2
A2儲存格值應自動存為a1
A3儲存格值應自動存為a10
A4儲存格值應自動存為a1
A5儲存格值應自動存為a1
A6儲存格值應自動存為a1
A7儲存格值應自動存為a3
A8儲存格值應自動存為a7
A9儲存格值應自動存為a1
A10儲存格值應自動存為a1
A11儲存格值應自動存為a1
A12儲存格值應自動存為a1

以上冗長的陳述希望能讓vba高手版主或有心為小女子解答之vba高手們了解
感激不盡
ps.原始版面編排為已上傳之上面附件book1
                               yupopo留
作者: GBKEE    時間: 2012-4-2 13:24

回復 3# YUPOYU
請傳上比對後檔案看看
作者: Hsieh    時間: 2012-4-2 14:51

回復 3# YUPOYU
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheet1
  4. For j = 2 To .[IV1].End(xlToLeft).Column
  5.     For i = 1 To .[A65536].End(xlUp).Row
  6.       If d(.Cells(i, j).Value) = "" Then
  7.       d(.Cells(i, j).Value) = .Cells(i, 1)
  8.       Else
  9.       d(.Cells(i, j).Value) = d(.Cells(i, j).Value) & "," & .Cells(i, 1)
  10.       End If
  11.     Next
  12. Next
  13. ay = Split(Join(d.items, ","), ",")
  14. End With
  15. With Sheet2
  16.   For Each a In .Range(.[A1], .[IV1].End(xlToLeft))
  17.   If d(a.Value) <> "" Then
  18.      If mystr = "" Then
  19.       mystr = d(a.Value)
  20.       Else
  21.       mystr = mystr & "," & d(a.Value)
  22.       End If
  23.   End If
  24.   Next
  25.     ar = Split(mystr, ",")
  26.     .[A2].Resize(UBound(ar) + 1, 1) = Application.Transpose(ar)
  27. End With
  28. End Sub
複製代碼
作者: register313    時間: 2012-4-2 15:02

回復 3# YUPOYU
  1. Sub aa()
  2.   Sheets("Sheet2").[A2:A65536] = ""
  3.   For R = 1 To Sheets("Sheet1").[A1].End(xlDown).Row
  4.     For C = 1 To Sheets("Sheet2").[A1].End(xlToRight).Column
  5.       If Sheets("Sheet2").Cells(1, C) = Sheets("Sheet1").Cells(R, C + 1) Then
  6.          Sheets("Sheet2").[A65536].End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(R, 1)
  7.       End If
  8.     Next C
  9.   Next R
  10. End Sub
複製代碼
作者: YUPOYU    時間: 2012-4-3 10:50

回復 5# Hsieh


    首先感謝HSIEH版主為小女子解出正確的解答,真的感激不盡
   我雖然看不太懂其中的深奧程式碼意思(我只懂簡單的回圈程式),
    但我會努力找書研究看看,我的8萬多筆的比對資料終於露出一線
     署光,有救了,感覺不是孤兒的感覺真是太棒了!我一定要贊助這佛
    心來的網站
        另外也感謝GBKEE及REGISTER313兩位的撥空關心
  ps. 如小女子屆時8萬多筆的比對資料,還是無法測試成功還望
            各位VBA大俠出手再相救囉!:P
                  謝謝大家
                                                   yupopo留
作者: YUPOYU    時間: 2012-4-3 21:20

回復 5# Hsieh


    DEAR HSIEH版主:
承蒙你的解答,小女子雖然很想靠自己的力量,弄懂版主寫的
程式,再應用在自己所需的範例中,但實在是和 HSIEH板主的實力懸殊差太多
雖然我有想辦法套用,但小女子應實際比對的8萬多筆的資料,還是無法測試成功,
希望好心的HSIEH板主再為快抓破頭的小女子看一下實際的問題再哪裡嗎?
不好意思,不曉得是否也可請HSIEH板主在每一行程式後面稍微註解一下
讓小女子我有機會來學習高手的設計思考模式
如願伸手援助,小女子感激不盡

[attach]10291[/attach]
PS.附件為實際的所遇到的case(book4.xls),
book4.xls!工具日期資料庫   就好像之前的   book1.xls!sheet1
book4.xls!檔期搜尋   就好像之前的   book1.xls!sheet2
book4.xls!工具日期資料庫 G5:G4000黃色儲存格  就好像之前的   book1.xls!sheet1 A1:A11
book4.xls!工具日期資料庫 B5:AE4000淡橘色儲存格區域  就好像之前的   book1.xls!sheet1 B1:K11
book4.xls!檔期搜尋A2:U2 就好像之前的   book1.xls!sheet2 A1:J1  只是儲存格的值為日期
想要顯示的結果就像之前比對後的排列方式
由book4.xls!檔期搜尋的A3.A4.A5........依序排列 就好像之前的   book1.xls!sheet2 A2.A3.A4........依序排列
程式套用在 book4.xls VBS的This Workbook 中,但一執行就出現錯誤訊息
真傷腦筋,HELP HELP.........!
作者: Hsieh    時間: 2012-4-3 22:31

回復 8# YUPOYU
不是模組位置的關係，是你的欄位起始位置不同
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheet1
  4. For j = 8 To .[IV5].End(xlToLeft).Column
  5.     For i = 5 To .[G65536].End(xlUp).Row
  6.       If d(.Cells(i, j).Value) = "" Then
  7.       d(.Cells(i, j).Value) = .Cells(i, 7)
  8.       Else
  9.       d(.Cells(i, j).Value) = d(.Cells(i, j).Value) & "," & .Cells(i, 7)
  10.       End If
  11.     Next
  12. Next
  13. ay = Split(Join(d.items, ","), ",")
  14. End With
  15. With Sheet2
  16.   For Each a In .Range(.[A2], .[IV2].End(xlToLeft))
  17.   If d(a.Value) <> "" Then
  18.      If mystr = "" Then
  19.       mystr = d(a.Value)
  20.       Else
  21.       mystr = mystr & "," & d(a.Value)
  22.       End If
  23.   End If
  24.   Next
  25.     ar = Split(mystr, ",")
  26.     .[A3].Resize(UBound(ar) + 1, 1) = Application.Transpose(ar)
  27. End With
  28. End Sub
複製代碼
作者: YUPOYU    時間: 2012-4-6 09:39

回復 9# Hsieh

感謝超版
我的問題已經解決
非常謝謝超版的耐心幫忙
小女子感激不盡:loveliness:

    YUPOPO留



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