麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] Cells.Find 如何讓找不到資料時就跳過 [打印本頁]

作者: JT1221 時間: 2022-9-2 12:00 標題: Cells.Find 如何讓找不到資料時就跳過

大家好

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

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

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

再請各位協助幫忙指出問題與解法，謝謝

Sub 替代料表用資材查詢220901()
'
Dim find_data, dat_rng, data_end, data_row, CleanFail
Application.ScreenUpdating = False
Sheets("查詢").Select
Range("B2:BQ16").ClearContents
For i = 2 To 16
If Cells(i, "A") = "" Then
Exit For
Else
find_data = Sheets("查詢").Cells(i, "A")
Cells(i, "A").Select
Sheets("總表").Select
date_end = Range(Selection, ActiveCell.SpecialCells(xlCellTypeLastCell)).Address
date_rng = "A1:" & date_end
Cells.Find(What:=find_data, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False).Activate
Selection.End(xlToRight).Select
Selection.Copy
Sheets("查詢").Select
Cells(i, "A").Select
ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("總表").Select
Selection.End(xlToRight).Offset(0, 1).Select
Selection.Copy
Sheets("查詢").Select
ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("總表").Select
Selection.Offset(0, 2).Select
Range(Selection, Selection.End(xlToRight)).Copy
Sheets("查詢").Select
ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
Cells(ActiveWindow.ActivePane.ScrollRow, ActiveWindow.ActivePane.ScrollColumn).Select
Application.ScreenUpdating = True
End Sub

複製代碼

作者: samwang 時間: 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

作者: JT1221 時間: 2022-9-2 15:49

本帖最後由 JT1221 於 2022-9-2 15:51 編輯

回復 2# samwang

Hi Sam

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

作者: Andy2483 時間: 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

作者: JT1221 時間: 2022-9-6 12:00

回復 4# Andy2483

Hi Andy
感謝回覆另外的寫法，我會在研究一下寫法!! :handshake

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