返回列表 上一主題 發帖

[發問] Cells.Find 如何讓找不到資料時就跳過

JT1221

帖子
9 
主題
3 
精華
0 
積分
62 
點名
1  
作業系統
Window 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
臺北 
註冊時間
2018-10-25 
最後登錄
2024-5-16 

2019 豬年全勤獎章
1# 跳轉到 » 正序看帖
打印
tT
發表於 2022-9-2 12:00 | 只看該作者

[發問] Cells.Find 如何讓找不到資料時就跳過

大家好

自己在製作表格查詢時，遇到Cells.Find的用法不知道如何能夠解決，
還請版本的各位能不吝指教，謝謝

說明：附近excel檔案有兩個頁面 (查詢、總表)，當把某一些材料號碼放到『查詢』頁面的A2-A16後，
           程式可以去總表把後面的資料 (包含舊資料、替代關係、可用機型)，貼到對應的欄位。

目前已經可以做查詢的功能，但如果『查詢的資料』在總表不存在就會出現以下錯誤，
『執行階段錯誤 '91':』
『沒有設定物件變數或With區塊變數』

再請各位協助幫忙指出問題與解法，謝謝
  1. Sub 替代料表用資材查詢220901()
  2. '
  3. Dim find_data, dat_rng, data_end, data_row, CleanFail
  4. Application.ScreenUpdating = False
  5. Sheets("查詢").Select
  6. Range("B2:BQ16").ClearContents

  8. For i = 2 To 16
  9.     If Cells(i, "A") = "" Then
  10.         Exit For
  11.     Else
  12.         find_data = Sheets("查詢").Cells(i, "A")
  13.         Cells(i, "A").Select
  14.         Sheets("總表").Select
  15.         date_end = Range(Selection, ActiveCell.SpecialCells(xlCellTypeLastCell)).Address
  16.         date_rng = "A1:" & date_end
  17.             
  18.         Cells.Find(What:=find_data, After:=ActiveCell, LookIn:=xlValues, _
  19.             LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
  20.             MatchCase:=False, MatchByte:=False, SearchFormat:=False).Activate
  21.                         
  22.         Selection.End(xlToRight).Select
  23.         Selection.Copy
  24.         Sheets("查詢").Select
  25.         Cells(i, "A").Select
  26.         ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  27.                 :=False, Transpose:=False
  28.         Sheets("總表").Select
  29.         Selection.End(xlToRight).Offset(0, 1).Select
  30.         Selection.Copy
  31.         Sheets("查詢").Select
  32.         ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  33.                 :=False, Transpose:=False
  34.         Sheets("總表").Select
  35.         Selection.Offset(0, 2).Select
  36.         Range(Selection, Selection.End(xlToRight)).Copy
  37.         Sheets("查詢").Select
  38.         ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  39.                 :=False, Transpose:=False

  41.     End If

  43. Next

  45. Cells(ActiveWindow.ActivePane.ScrollRow, ActiveWindow.ActivePane.ScrollColumn).Select
  46. Application.ScreenUpdating = True

  48. End Sub
複製代碼

CUT.JPG (134.13 KB)

CUT.JPG

試驗料表up.rar (36.75 KB)

替代

收藏 分享
VBA 新手進化中

JT1221

帖子
9 
主題
3 
精華
0 
積分
62 
點名
1  
作業系統
Window 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
臺北 
註冊時間
2018-10-25 
最後登錄
2024-5-16 

2019 豬年全勤獎章
5#
發表於 2022-9-6 12:00 | 只看該作者
回復 4# Andy2483

    Hi Andy
         感謝回覆另外的寫法，我會在研究一下寫法!!  :handshake
VBA 新手進化中

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
4#
發表於 2022-9-2 16:48 | 只看該作者
回復 1# JT1221


    另類查詢方式供前輩參考
謝謝前輩發表此帖

Option Explicit
Sub test()
Dim i, x, Arr, Brr(1 To 100000, 1 To 9), c, j, n, Crr
Arr = Sheets("總表").Range("A1").CurrentRegion
Crr = Sheets("查詢").Range("A1").CurrentRegion
c = Sheets("總表").UsedRange.Columns.Count
For i = 1 To UBound(Arr)
   For j = 8 To c
      If Trim(Arr(i, j)) = "" Or Trim(Arr(i, j)) = "A=B,A=C→B=C" Then
         Exit For
         Else
            n = n + 1
            Brr(n, 8) = Trim(Arr(i, j))
            For x = 1 To 7
               Brr(n, x) = Trim(Arr(i, x))
            Next
      End If
   Next
Next
Workbooks.Add
Cells.Font.Name = "微軟正黑體"
[A1].Resize(100000, 9) = Brr
Cells.Columns.AutoFit
Cells.Rows.AutoFit
Cells.Columns.AutoFit
[2:2].Select
ActiveWindow.FreezePanes = True
[A1].AutoFilter
[A1].Select
ActiveSheet.Name = "新總表"
Sheets.Add.Name = "新查詢"
[A1].Resize(UBound(Crr), 4) = Crr
For i = 1 To UBound(Crr)
   For x = 2 To UBound(Brr)
      If Brr(x, 1) = Crr(i, 1) Then
         If Crr(i, 2) = "" Then
            Crr(i, 2) = Brr(x, 3)
         End If
         If Crr(i, 3) = "" Then
            Crr(i, 3) = Brr(x, 6)
         End If
         If Crr(i, 4) = "" Then
            Crr(i, 4) = Brr(x, 8)
            Else
               Crr(i, 4) = Crr(i, 4) & vbLf & Brr(x, 8)
         End If
      End If
   Next
Next
[A1].Resize(UBound(Crr), 4) = Crr
[A:D].Columns.AutoFit
Cells.Rows.AutoFit
Cells.Borders.LineStyle = xlContinuous
[2:2].Select
ActiveWindow.FreezePanes = True
[A1].AutoFilter
[A1].Select
End Sub

TOP

JT1221

帖子
9 
主題
3 
精華
0 
積分
62 
點名
1  
作業系統
Window 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
臺北 
註冊時間
2018-10-25 
最後登錄
2024-5-16 

2019 豬年全勤獎章
3#
發表於 2022-9-2 15:49 | 只看該作者
本帖最後由 JT1221 於 2022-9-2 15:51 編輯

回復 2# samwang


Hi Sam

感謝回覆，查詢的資料完全正確
程式碼也精簡非常多!
再次感謝!  {:3_61:}
VBA 新手進化中

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
2#
發表於 2022-9-2 15:07 | 只看該作者
回復 1# JT1221

請測試看看，謝謝
Sub test()
Dim Arr, Brr, Crr(), i&, x&, j%
Brr = Sheets("總表").Range("a1").CurrentRegion
Arr = Sheets("查詢").Range("a1").CurrentRegion
ReDim Crr(1 To UBound(Arr), 1 To UBound(Brr, 2))
For i = 2 To UBound(Arr)
    For x = 2 To UBound(Brr)
        If Arr(i, 1) = Brr(x, 1) Then
            Crr(i - 1, 1) = Brr(x, 3): Crr(i - 1, 2) = Brr(x, 6)
            For j = 8 To UBound(Brr, 2): Crr(i - 1, j - 5) = Brr(x, j): Next
        End If
    Next
Next
Sheets("查詢").Range("b2").Resize(UBound(Arr), UBound(Brr, 2)) = Crr
End Sub

TOP

        靜思自在 : 不怕事多，只怕多事。
返回列表 上一主題