返回列表 上一主題 發帖

[發問] 請問VBA 的程式有沒有可以辨認某個儲存格內的字元有無包含某幾個字串?

回復 10# 198188


    大大您寫的好長....
    將兩個活頁簿合併成一個檔案判斷.. (寫法和 兩個活頁簿分開的寫法差不多)
   根據您所發問的問題,以簡易的程式判斷..

st1 = 工作表1.Range("a2").CurrentRegion.Rows.Count
st2 = 工作表2.Range("d2").CurrentRegion.Rows.Count

For k1 = 2 To st1
    For k2 = 2 To 233
        If 工作表2.Cells(k2, "D") = 工作表1.Cells(k1, "A") And (InStr(1, 工作表2.Cells(k2, "H"), "OBL") >= 1) Then
         '工作表2.Cells(k2, "c") = "對應到" & 工作表1.Cells(k1, "A")'此行為 在工作表2 C欄標註 D欄位是否有符合 工作表1  A欄位
         工作表1.Cells(k1, "J") = 工作表2.Cells(k2, "H")
        End If
    Next
Next

  多做多想多學習,少看少錯少迷途

  多做=多多練習,多多編寫。
  多想=想想為什麼人家程式要那樣寫,如果換成自己,又會怎寫。
  多學習=學習人家的發問並解答,學習人家的寫法

  少看=只看不做也枉然

TOP

回復 11# mark15jill
  1. Sub State_Detail()
  2. Dim FRng As Range
  3. Dim a As Range, Rng As Range
  4. Dim i As Integer
  5. Dim LastRec As Integer
  6. Dim z As Integer
  7. Dim y As Integer
  8. Dim x As Integer
  9. Dim w As Integer

  10. z = Sheets("state").Range("a2").CurrentRegion.Rows.Count
  11. fs = "C:\Documents and Settings\USER\桌面\DOCS RECEIVED N RELEASED RECORD.xlsx"
  12. Set WB = Workbooks.Open(fs)

  13. With ThisWorkbook.Worksheets("State")

  14. x = 2
  15. For w = 2 To z
  16.     Do
  17.         If WB.Sheets("收件記錄").Cells(x, "D") = Sheets("state").Cells(w, "A") And (InStr(1, WB.Sheets("收件記錄").Cells(x, "H"), "OBL") >= 1) Then
  18.                  Sheets("state").Cells(w, "J") = WB.Sheets("收件記錄").Cells(x, "H")
  19.         End If
  20.         x = x + 1
  21.    Loop Until x = WB.Sheets("收件記錄").Row.Count.End(xlUp)
  22. Next

  23. End With
  24. WB.Close 0
  25. End Sub
複製代碼
出現執行階段錯誤9 陣列索引超出範圍

TOP

回復 12# 198188
會出現超出陣列索引錯誤是因為你在開啟來源檔以後,一般模組內程式碼若沒指定活頁簿,則會以當前作用中的活頁簿作為該活頁簿
通常我會這麼做,比較容易找出錯誤點
  1. Sub ex()
  2. Dim Sh As Worksheet, Rng As Range
  3. fd = ThisWorkbook.Path & "\"  '資料來源目錄
  4. fs = "DOCS RECEIVED N RELEASED RECORD.xlsx" '資料來源檔案(含副檔名)
  5. With Workbooks.Open(fd & fs)
  6.   Set Sh = .Sheets("收件記錄")
  7.       With ThisWorkbook.Sheets("State")
  8.          For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
  9.             Set Rng = Sh.Columns("D").Find(A, lookat:=xlWhole)
  10.             If Not Rng Is Nothing Then
  11.                If InStr(Rng.Offset(, 4), "OBL") > 0 Then _
  12.                A.Offset(, 9) = Rng.Offset(, 4).Value Else A.Offset(, 9) = ""
  13.             End If
  14.          Next
  15.       End With
  16.     .Close
  17. End With
  18. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 13# Hsieh


    有個問題,因為我的DATA BASE裏的訂單號會重複幾次, Set Rng = Sh.Columns("D").Find(a, lookat:=xlWhole) 這句只是會找一次
例如:
200000     PLANT INV
200000     OHC
200000     OBL
200000     CO
200000     遲証信

211111     OBL
211111     OHC
211111     CO

222222     OHC
222222     CO
222222     OBL
效果就無法出現
因為我是想只要訂單號相同,而且這些訂單號只要有一列有OBL三個字,就出現OBL否則空格

TOP

本帖最後由 GBKEE 於 2013-3-9 12:52 編輯

回復 14# 198188
Set Rng = Sh.Columns("D").Find(a, lookat:=xlWhole) 這句只是會找一次
如下可尋找全部
  1. Option Explicit
  2. Sub Ex()
  3.     Dim A As String, Rng As Range, Sh As Worksheet, Address_First As String
  4.     Dim M As String
  5.     Set Sh = ActiveSheet
  6.     A = "OBL"                                          '尋找的字串
  7.     Set Rng = Sh.Columns("D").Find(A, lookat:=xlWhole) '第一個
  8.     If Not Rng Is Nothing Then
  9.         Address_First = Rng.Address                    '寫下第一個位址
  10.         Do
  11.             M = IIf(M <> "", M & ",", "") & Rng.Address
  12.             Set Rng = Sh.Columns("D").FindNext(Rng)   '繼續尋找下一個
  13.         Loop Until Address_First = Rng.Address        '回到第一個位址
  14.         MsgBox M
  15.      Else
  16.         MsgBox "找不到"
  17.     End If
  18. End Sub
  19. Sub Ex_1()
  20.     Dim A As String, Rng As Range, Sh As Worksheet, Address_First
  21.     Set Sh = ActiveSheet
  22.     A = "OBL"                                           '尋找的字串
  23.     Set Rng = Sh.Columns("D").Find(A, lookat:=xlWhole)  '第一個
  24.     If Not Rng Is Nothing Then
  25.         With Sh.Columns("D")
  26.             .Replace A, "=ABC", xlWhole                 '修改"尋找的字串" = 沒定義的名稱
  27.             Set Rng = .SpecialCells(xlCellTypeFormulas, xlErrors) '儲存格有錯誤值的特定範圍
  28.             Rng.Value = A                                '沒定義的名稱 改回 "尋找的字串"
  29.             MsgBox Rng.Address
  30.         End With
  31.     Else
  32.         MsgBox "找不到"
  33.     End If
  34. End Sub
複製代碼
因為我是想只要訂單號相同,而且這些訂單號只要有一列有OBL三個字,就出現OBL否則空格
不了解你檔案內容 無法回答

TOP

回復 15# GBKEE


我想要的效果是根據Test.xlsm的State Sheet 的A欄的訂單號,來尋找DOCS RECEIVED N RELEASED RECORD.xlsx 收單記錄SHEET內D欄是否有相同的訂單號和H欄的字元內包含"OBL"三個字(大小寫都沒有問題可以讀到),如果有,在Test.xlsm的State Sheet 的相應的訂單號J欄顯示DOCS RECEIVED N RELEASED RECORD.xlsx 收單記錄SHEET內H欄的資料。如果沒有就空格。
前面有附件
Test.xlsm
State sheet
A欄                J欄
20000          OBL-3
20001
20002
20003          OBL
20004          OBL

W:\Payment Daily Report\DOCS RECEIVED N RELEASED RECORD.xlsx"
收單記錄SHEET
D欄                          H欄
20000                     遲証信
20000                     OBL-3
20003                     OHC(BODY-1,OIE-1,ACCEPTED BSE-1),CO
20000                     OHC(BODY-1,HPAI-1)
20004                     OHC(BODY-1,OIE-1,ACCEPTED BSE-1,AD-1,CL-1)
20005                     OHC(BODY-1)
20003                     OBL
20003                     INV
20005                     INV
20005                     OBL
20004                     OBL

TOP

回復 16# 198188
  1. Option Explicit
  2. Sub Ex()
  3.     Dim R As Range, Rng As Range, E As Range
  4.     With Sheet1                         '*** 須改為: Test.xlsm的State Sheet
  5.         Set R = .Cells(1, "a")          'A1開始
  6.         Do Until R = ""                 '離開迴圈的條件:  A欄的 儲存格=""
  7.             With Sheet2                 '*** 須改為: W:\Payment Daily Report\DOCS RECEIVED N RELEASED RECORD.xlsx"
  8.                 Set Rng = .Columns("D").Find(R, lookat:=xlWhole)
  9.                  If Not Rng Is Nothing Then
  10.                     With .Columns("D")
  11.                         .Replace R, "=ABC", xlWhole                 '修改"尋找的字串" = 沒定義的名稱
  12.                         Set Rng = .SpecialCells(xlCellTypeFormulas, xlErrors) '儲存格有錯誤值的特定範圍
  13.                         Rng.Value = R                               '沒定義的名稱 改回 "尋找的字串"
  14.                         For Each E In Rng.Offset(0, 4)              'D欄位移4欄=H欄
  15.                             If InStr(UCase(E), "OBL") Then          'H欄的字元內包含"OBL"三個字
  16.                                                                     'UCase(E) 轉換為大寫
  17.                                 R.Offset(0, 9) = E.Value            'R.Offset(0, 9)-> A欄位移到 J欄
  18.                                 'Test.xlsm的State Sheet->J欄=DOCS RECEIVED N RELEASED RECORD.xlsx"->H欄的字元
  19.                                 Exit For    '有找到 "OBL" 離開迴圈                          '
  20.                             End If
  21.                        Next
  22.                     End With                '.Columns("D")
  23.                 End If
  24.             End With                        'Sheet2
  25.             Set R = R.Offset(1)             '下移到 A2
  26.         Loop
  27.     End With                                'Sheet1
  28. End Sub
複製代碼

TOP

回復 14# 198188
  1. Sub ex()
  2. Dim Sh As Worksheet, Rng As Range, C As Range, Ar()
  3. fd = ThisWorkbook.Path & "\"  '資料來源目錄
  4. fs = "DOCS RECEIVED N RELEASED RECORD.xlsx" '資料來源檔案(含副檔名)
  5. With Workbooks.Open(fd & fs)
  6.   Set Sh = .Sheets("收件記錄")
  7.       With ThisWorkbook.Sheets("State")
  8.          For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
  9.             Set Rng = Sh.Columns("D").Find(A, lookat:=xlWhole)
  10.             If Not Rng Is Nothing Then
  11.                For Each C In Sh.Range(Rng, Sh.Cells(Sh.Rows.Count, 4).End(xlUp))
  12.                   If C = A And InStr(UCase(C.Offset(, 4)), "OBL") > 0 Then
  13.                      ReDim Preserve Ar(s)
  14.                      Ar(s) = C.Offset(, 4)
  15.                      s = s + 1
  16.                   End If
  17.                 Next
  18.             If s > 0 Then A.Offset(, 9) = Join(Ar, "、"): Erase Ar: s = 0 Else A.Offset(, 9) = ""
  19.             End If
  20.          Next
  21.       End With
  22.     .Close
  23. End With
  24. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 18# Hsieh

可以了,感謝大大

fd = ThisWorkbook.Path & "\"  '資料來源目錄
fs = "DOCS RECEIVED N RELEASED RECORD.xlsx" '資料來源檔案(含副檔名)
另外請問上面兩句
如果我寫這句替代上面兩句fs = "W:\PIHK\DOCS RECEIVED N RELEASED RECORD.xlsx"
或者
fd = W:\PIHK\
fs = "DOCS RECEIVED N RELEASED RECORD.xlsx" '資料來源檔案(含副檔名)
這樣對嗎?

Join(Ar, "、"): Erase 這句是什麼意思?

另外請問如果我本來在state表的J欄已經有資料,會因應達到條件而取替資料,但如果要該儲存格是空格才取替

If s > 0 and trim(a.Offset(,9) )=“”Then a.Offset(, 9) = Join(Ar, "、"): Erase Ar: s = 0 Else a.Offset(, 9) = "" 這樣寫對嗎?

TOP

回復 17# GBKEE


With Sheet1                        (這句是否改With State sheet?)
With Sheet2                 (這句是否改With W:\Payment Daily Report\DOCS RECEIVED N RELEASED RECORD.xlsx ?)但是好像不對??

TOP

        靜思自在 : 發脾氣是短暫的發瘋。
返回列表 上一主題