1234
返回列表 上一主題 發帖

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

mark15jill
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
11# 跳轉到 »
發表於 2013-3-8 16:41 | 只看該作者
回復 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

198188

帖子
438 
主題
67 
精華
0 
積分
531 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-5-28 
12#
發表於 2013-3-8 22:25 | 只看該作者
回復 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

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

  15. With ThisWorkbook.Worksheets("State")

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

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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
13#
發表於 2013-3-8 23:14 | 只看該作者
回復 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

198188

帖子
438 
主題
67 
精華
0 
積分
531 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-5-28 
14#
發表於 2013-3-9 09:38 | 只看該作者
回復 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

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
15#
發表於 2013-3-9 11:23 | 只看該作者
本帖最後由 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

198188

帖子
438 
主題
67 
精華
0 
積分
531 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-5-28 
16#
發表於 2013-3-9 11:44 | 只看該作者
回復 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
17#
發表於 2013-3-9 13:15 | 只看該作者
回復 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

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
18#
發表於 2013-3-9 21:46 | 只看該作者
回復 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

198188

帖子
438 
主題
67 
精華
0 
積分
531 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-5-28 
19#
發表於 2013-3-9 22:54 | 只看該作者
回復 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

198188

帖子
438 
主題
67 
精華
0 
積分
531 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-5-28 
20#
發表於 2013-3-9 23:00 | 只看該作者
回復 17# GBKEE


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

TOP

        靜思自在 : 【時間如鑽石】時間對一個有智慧的人而言，就如鑽石般珍貴；但對愚人來說，卻像是一把泥土，一點價值也沒有。
1234
返回列表 上一主題