Board logo

標題: 請教比對工作表相同的項目 [打印本頁]
作者: bhsm    時間: 2012-4-13 13:14     標題: 請教比對工作表相同的項目

各位前輩好:
       小弟想比較8個工作表中A欄相同的值,列於Main工作表中,小弟有參考網路的前輩寫的VBA自行修改,但卻無法比對,不知VBA哪裡有錯?請指教.謝謝.
       [attach]10426[/attach]
作者: GBKEE    時間: 2012-4-13 13:49

回復 1# bhsm
A欄相同的值 要說明白
作者: bhsm    時間: 2012-4-13 15:53

對不起沒說清楚
以"2883開發金"為例,在"一銀.台銀.土銀.台企.兆豐.合庫.華南.彰銀"工作表中.共出現7次
以"2330台積電"為例,在"一銀.台銀.土銀.台企.兆豐.合庫.華南.彰銀"工作表中.共出現6次
其他還有各股各出現的次數
想請教的是: 是否可用vba找出在這8個工作表中.同時出現的股票及次數填入Main工作表中.謝謝
作者: register313    時間: 2012-4-13 19:50

回復 3# bhsm
  1. Sub YY()
  2. R = 1: C = 0
  3. Sheets("相同").Columns("A:B") = ""
  4. For Each Sh In Sheets
  5.   If Sh.Name <> "相同" Then
  6.      For Each Rng In Range(Sh.[A6], Sh.[A6].End(xlDown))
  7.        With Sheets("相同")
  8.          If Application.CountIf(.Columns("A"), Rng.Value) = 0 Then
  9.             .Cells(R, 1) = Rng.Value
  10.             .Cells(R, 2) = C + 1
  11.             R = R + 1
  12.          Else
  13.             x = Application.Match(Rng.Value, .Columns("A"), 0)
  14.             .Cells(x, 2) = .Cells(x, 2) + 1
  15.          End If
  16.        End With
  17.      Next
  18.   End If
  19. Next
  20. End Sub
複製代碼
作者: GBKEE    時間: 2012-4-13 21:18

本帖最後由 GBKEE 於 2012-4-13 21:30 編輯

回復 3# bhsm
還有賣超一併回答   使用工作表 指令 資料  ->   合併彙算  很快的
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ar1(), Ar2(), xl As Integer, Rng As Range, xF As Range
  4.     Sheets("相同").Move Before:=Sheets(1)
  5.     ReDim  Ar1(2 To Sheets.Count)
  6.     ReDim  Ar2(2 To Sheets.Count)
  7.     For xl = 2 To Sheets.Count
  8.         With Sheets(xl)
  9.             Set Rng = .Range("A5", .[A5].End(xlDown)(1, 2))
  10.             Ar1(xl) = Rng.Address(, , xlR1C1, 1)
  11.             Set Rng = .Range("E5", .[E5].End(xlDown)(1, 2))
  12.             Ar2(xl) = Rng.Address(, , xlR1C1, 1)
  13.         End With
  14.     Next
  15.     With Sheets(1)
  16.         .Cells = ""
  17.         .[A1] = "買超"
  18.         .[A2].Consolidate Sources:=Ar1, Function:=xlCount, TopRow:=False, LeftColumn:=True, CreateLinks:=False
  19.         .[A2].Consolidate Sources:=Ar1, Function:=xlCount, TopRow:=True, LeftColumn:=True, CreateLinks:=False
  20.         .[E1] = "賣超"
  21.         .[E2].Consolidate Sources:=Ar2, Function:=xlCount, TopRow:=False, LeftColumn:=True, CreateLinks:=False
  22.         .[E2].Consolidate Sources:=Ar2, Function:=xlCount, TopRow:=True, LeftColumn:=True, CreateLinks:=False
  23.     End With
  24. End Sub
複製代碼
作者: bhsm    時間: 2012-4-13 21:24

感謝register313 大大,非常實用,小弟先消化一下,若有問題尚請不吝指教.謝謝
作者: bhsm    時間: 2012-4-13 22:38

感謝GBKEE大大,您真是設想周到.小弟沒想到的.您都替我想到了.真是謝謝.



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