12
返回列表 上一主題 發帖

[發問] 請問各位前輩關於Find 與比對Range 問題

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
11# 跳轉到 »
發表於 2014-8-18 19:49 | 只看該作者
回復 10# ii31sakura
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, Rng As Range, S As String
  4.     Set d = CreateObject("scripting.dictionary")
  5.     Set Rng = Sheets("比對data").Range("A2")
  6.     Do While Rng <> ""
  7.         d(Rng & Rng.Cells(1, 2) & Rng.Cells(1, 3)) = ""
  8.         Set Rng = Rng.Cells(2, 1)
  9.     Loop
  10.     Set Rng = Sheets("來源data").Range("A2")
  11.     Do While Rng <> ""
  12.         If d.EXISTS(Rng & Rng.Cells(1, 2) & Rng.Cells(1, 3)) Then
  13.             If d.EXISTS("比對到") Then
  14.                 Set d("比對到") = Union(Rng.Resize(, 3), d("比對到"))
  15.             Else
  16.                 Set d("比對到") = Rng.Resize(, 3)
  17.             End If
  18.         
  19.             S = IIf(S <> "", S & vbLf, "") & Rng.Address(0, 0) & " 找到 " & Rng & "-" & Rng.Cells(1, 2) & "-" & Rng.Cells(1, 3)
  20.         End If
  21.         Set Rng = Rng.Cells(2, 1)
  22.     Loop
  23.     If S <> "" Then
  24.         d("比對到").Parent.Activate
  25.          d("比對到").Select
  26.         MsgBox "來源data " & vbLf & S
  27.     End If
  28. End Sub
  29. Sub Ex3()
  30.     Dim Rng(1 To 2) As Range, Rng2_Address As String
  31.     Set Rng(1) = Worksheets("比對data").Range("A2")                    '比對data的第一筆資料(日期)
  32.     Sheets("來源data").UsedRange.Offset(1).Interior.ColorIndex = xlNone
  33.     Do While Rng(1) <> ""                                              '執行到條件不成立
  34.         With Sheets("來源data").Range("A:A")                           '範圍:這工作表的A欄
  35.             Set Rng(2) = .Find(Rng(1), AFTER:=.Cells(1), LookIn:=xlFormulas) '搜尋日期:要用公式LookIn:=xlFormulas
  36.             Do While Not Rng(2) Is Nothing                              '執行到條件不成立
  37.                 If Rng2_Address = "" Then Rng2_Address = Rng(2).Address '記錄第一次找到的位置
  38.                 If Rng(1).Cells(1, 2) = Rng(2).Cells(1, 2) And Rng(1).Cells(1, 3) = Rng(2).Cells(1, 3) Then      '
  39. '                     Rng(1).Cells(1, 3) = Rng(2).Cells(1, 3)             '比對的第二欄=來源data的第二欄
  40.                     
  41.                     Rng(1).Cells(1, 4) = Rng(2).Row '此段為找該資料的row
  42.                     Rng(2).Resize(, 3).Interior.Color = vbYellow
  43.                     
  44.                     Exit Do
  45.                 End If
  46.                 Set Rng(2) = .FindNext(Rng(2))                          '繼續往下搜尋
  47.                 If Rng2_Address = Rng(2).Address Then                   '回到第一次找到的位置
  48.                     Exit Do                                             '離開迴圈
  49.                 End If
  50.             Loop
  51.             Rng2_Address = ""
  52.             Set Rng(1) = Rng(1).Offset(1)                               '比對data的下一筆資料(日期)
  53.         End With
  54.     Loop
  55. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

ii31sakura

帖子
43 
主題
13 
精華
0 
積分
75 
點名
0  
作業系統
windows 7 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2014-5-6 
最後登錄
2019-6-17 
12#
發表於 2014-8-18 21:54 | 只看該作者
回復 11# GBKEE

感謝GBKEE前輩指導兩個方法、讓小弟可以有多一層空間變化，
不好意思如果小弟套用的來源端屬於不同excel、
故使用以下方式進行設定、但似乎漏了哪個環節而導致無法執行，
因嘗試許久無法正解、請問能不能再請幫忙看一下呢？

find 與比對Range 問題1.zip (25.65 KB)

程式碼：
Sub Ex3()
    Dim Rng(1 To 2) As Range, Rng2_Address As String
     Dim wb(1 To 2) As Workbook
    Dim myApp As New Application
   
   
     Set wb(1) = ThisWorkbook '使用於sheet(比對data)
    Set wb(2) = myApp.Workbooks.Open(Worksheets("路徑區").Cells(2, 3) & "\" & Worksheets("路徑區").Cells(2, 2))  '使用於另一個excel sheet(來源data)
   
    Set Rng(1) = wb(1).Worksheets("比對data").Range("A2")                    '比對data的第一筆資料(日期)
    Do While Rng(1) <> ""                                              '執行到條件不成立
        With wb(2).Sheets("來源data").Range("A:A")                           '範圍:這工作表的A欄
            Set Rng(2) = .Find(Rng(1), AFTER:=.Cells(1), LookIn:=xlFormulas) '搜尋日期:要用公式LookIn:=xlFormulas
            Do While Not Rng(2) Is Nothing                              '執行到條件不成立
                If Rng2_Address = "" Then Rng2_Address = Rng(2).Address '記錄第一次找到的位置
                If Rng(1).Cells(1, 2) = Rng(2).Cells(1, 2) Then     '
'                    Rng(1).Cells(1, 3) = Rng(2).Cells(1, 3)             '比對的第二欄=來源data的第二欄
                    
                    Rng(1).Cells(1, 3) = Rng(2).Row '此段為找該資料的row
                    
                    Exit Do
                End If
                Set Rng(2) = .FindNext(Rng(2))                          '繼續往下搜尋
                If Rng2_Address = Rng(2).Address Then                   '回到第一次找到的位置
                    Exit Do                                             '離開迴圈
                End If
            Loop
            Rng2_Address = ""
            Set Rng(1) = Rng(1).Offset(1)                               '比對data的下一筆資料(日期)
        End With
    Loop
   
   
       wb(2).Close False
        
        
        Set wb(1) = Nothing
        Set wb(2) = Nothing
        Set Rng(1) = Nothing: Set Rng(2) = Nothing
'        Set findvalue = Nothing
End Sub

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
13#
發表於 2014-8-19 10:41 | 只看該作者
回復 12# ii31sakura
  1. Dim myApp As New Application
  2. With wb(2).Sheets("來源data").Range("A:A")                           '範圍:這工作表的A欄
  3. Set Rng(2) = .Find(Rng(1).Value, AFTER:=.Cells(1), LookIn:=xlFormulas) '搜尋日期:要用公式LookIn:=xlFormulas
複製代碼
Rng(2) is nothing 無法突破

試試不新開 Excel 應用程式
  1. Sub Ex3()
  2.     Dim Rng(1 To 3) As Range, Rng2_Address As String
  3.     Dim wb(1 To 2) As Workbook
  4.    ' Dim myApp As New Application  '為何要新開 Excel
  5.     Set wb(1) = ThisWorkbook '使用於sheet(比對data)
  6.     'Set wb(2) = myApp.Workbooks.Open(Worksheets("路徑區").Cells(2, 3) & "\" & Worksheets("路徑區").Cells(2, 2))  '使用於另一個excel sheet(來源data)
  7.     Set wb(2) = Workbooks.Open(Worksheets("路徑區").Cells(2, 3) & "\" & Worksheets("路徑區").Cells(2, 2))  '使用於另一個excel sheet(來源data)
  8.     Set Rng(1) = wb(1).Worksheets("比對data").Range("A2")                    '比對data的第一筆資料(日期)
  9.     Do While Rng(1) <> ""                                              '執行到條件不成立
  10.         With wb(2).Sheets("來源data").Range("A:A")                           '範圍:這工作表的A欄
  11.             Set Rng(2) = .Find(Rng(1).Value, AFTER:=.Cells(1), LookIn:=xlFormulas) '搜尋日期:要用公式LookIn:=xlFormulas
  12.             Do While Not Rng(2) Is Nothing                              '執行到條件不成立
  13.                 If Rng2_Address = "" Then Rng2_Address = Rng(2).Address '記錄第一次找到的位置
  14.                 If Rng(1).Cells(1, 2) = Rng(2).Cells(1, 2) Then     '
  15. '                    Rng(1).Cells(1, 3) = Rng(2).Cells(1, 3)             '比對的第二欄=來源data的第二欄
  16.                   
  17.                    ' Rng(1).Cells(1, 3) = Rng(2).Row '此段為找該資料的row
  18.                    '******************
  19.                     If Rng(3) Is Nothing Then
  20.                         Set Rng(3) = Rng(2).Resize(, 3)
  21.                     Else
  22.                     
  23.                         Set Rng(3) = Union(Rng(3), Rng(2).Resize(, 3))
  24.                     End If
  25.                     '*********************
  26.                     Exit Do
  27.                 End If
  28.                 Set Rng(2) = .FindNext(Rng(2))                          '繼續往下搜尋
  29.                 If Rng2_Address = Rng(2).Address Then                   '回到第一次找到的位置
  30.                     Exit Do                                             '離開迴圈
  31.                 End If
  32.             Loop
  33.             Rng2_Address = ""
  34.             Set Rng(1) = Rng(1).Offset(1)                               '比對data的下一筆資料(日期)
  35.         End With
  36.     Loop
  37.     If Not Rng(3) Is Nothing Then
  38.          With wb(1).Worksheets("總整理")
  39.             .UsedRange.Offset(1) = ""
  40.             Rng(3).Copy .Range("A2")
  41.         End With
  42.     End If
  43.        wb(2).Close False
  44.        Set wb(1) = Nothing
  45.         Set wb(2) = Nothing
  46.         Set Rng(1) = Nothing
  47.         Set Rng(2) = Nothing

  49. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

ii31sakura

帖子
43 
主題
13 
精華
0 
積分
75 
點名
0  
作業系統
windows 7 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2014-5-6 
最後登錄
2019-6-17 
14#
發表於 2014-8-19 12:13 | 只看該作者
回復 13# GBKEE


    感謝GBKEE前輩指導、因為小弟的資料來源大多為區網上的共用excel data，
    會使用例子1因擔心可能來源data已先被其它人開啟會有開啟警告問題，
    經前輩提醒後、小弟實際去測試使用例子2、即使有人開起來源data也似乎不影響程式的運行，
    在此謝謝前輩的指導囉~

例子1：' Dim myApp As New Application  '為何要新開 Excel
例子2：Set wb(2) = Workbooks.Open

TOP

ii31sakura

帖子
43 
主題
13 
精華
0 
積分
75 
點名
0  
作業系統
windows 7 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2014-5-6 
最後登錄
2019-6-17 
15#
發表於 2014-8-19 17:05 | 只看該作者
回復 13# GBKEE

不好意思 GBKEE前輩，因小弟工作關係需套用於別處、請問如果來源資料wb(2)開起時出現如下圖的( 無法更新的連結)，
請問該如何將來源資料的自動更新關閉呢？

註：小弟爬文嘗試使用語句2來關閉來源資料警告、但可能卡在語句1已經先開啟，所以總是出現錯誤情況。

語句1： Set wb(2) = Workbooks.Open(Worksheets("路徑區").Cells(2, 3) & "\" & Worksheets("路徑區").Cells(2, 2))  '使用於另一個excel sheet(來源data)
語句2：Workbooks.Open Filename:="D:\週別資料\wk1432\find 比對問題\find 與比對Range 問題3 - 來源data.xlsm" ,UpdateLinks:=0

TOP

ii31sakura

帖子
43 
主題
13 
精華
0 
積分
75 
點名
0  
作業系統
windows 7 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2014-5-6 
最後登錄
2019-6-17 
16#
發表於 2014-8-19 19:11 | 只看該作者
回復 13# GBKEE

GBKEE前輩~不好意思…後來小弟嘗試在開啟檔案前加上"Application.DisplayAlerts = False '關閉所有EXCEL程序系統提示"之後就可以正常值行了，
真是不好意思這麼麻煩您。
   

感謝前輩前幾段的指導~

TOP

        靜思自在 : 改變自己是自救，影響別人是救人。
12
返回列表 上一主題