我需要幫助修改下面的代碼以查看整個作業簿搜索“$”而不是一個。如果它可以只搜索 CGYSR-“##”，我會喜歡它。由于我是 VBA 新手，我得到了幫助將代碼放在一起
這是代碼：
Option Explicit
Sub FindPriceTagInformation()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the search Value
MyArr = Array("$")
Set NewSh = Sheets("Sheet2")
With Sheets("CGYSR-3").Range("A1:ZZ300")
Rcount = 0
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount 1
NewSh.Cells(Rcount, 3).Value = Rng.Value
NewSh.Cells(Rcount, 2).Value = Rng.Offset(-3, 0).Value
NewSh.Cells(Rcount, 1).Value = Rng.Offset(-5, 0).Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
uj5u.com熱心網友回復：
請嘗試下一個改編的代碼：
Sub FindPriceTagInformation()
Dim FirstAddress As String, MyArr, Rng As Range, Rcount As Long, I As Long
Dim ws As Worksheet, NewSh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the search Value
MyArr = Array("$")
Set NewSh = Sheets("Sheet2")
Rcount = 0
For Each ws In ActiveWorkbook.Sheets
If left(ws.Name, 6) = "CGYSR-" Then
With ws.Range("A1:ZZ300")
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.cells(.cells.count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount 1
NewSh.cells(Rcount, 3).value = Rng.value
NewSh.cells(Rcount, 2).value = Rng.Offset(-3, 0).value
NewSh.cells(Rcount, 1).value = Rng.Offset(-5, 0).value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End If
Next ws
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
uj5u.com熱心網友回復：
在作業表中搜索
- 在包含此代碼 (
ThisWorkbook)的作業簿中，回圈遍歷每個作業表，嘗試識別名稱以給定字串 (CGYSR-)開頭的作業表。然后它搜索$具有價格的標識單元格并檢索這些單元格的值和其他兩個關聯單元格（上面的 3 和 5 個單元格）的值，并將它們寫入另一個作業表 (Sheet2) 中的一行。
Option Explicit
Sub FindPriceTagInformation()
Const swsNameBegin As String = "CGYSR-"
Const srgAddress As String = "A1:ZZ300"
Const dwsName As String = "Sheet2"
Dim SearchStrings As Variant: SearchStrings = Array("$")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Destination Worksheet
Dim dws As Worksheet: Set dws = wb.Worksheets(dwsName)
' You do it once here, so you don't have to do it many times in the loops.
Dim sCellsCount As Long: sCellsCount = dws.Range(srgAddress).Cells.Count
Dim npLen As String: npLen = Len(swsNameBegin)
Dim ssLower As Long: ssLower = LBound(SearchStrings)
Dim ssUpper As Long: ssUpper = UBound(SearchStrings)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Srouce Range
Dim sfCell As Range ' Source Found Cell
Dim slCell As Range ' Source Last Cell
Dim dr As Long ' Current Destination Row
Dim ss As Long ' Current Search String
Dim FirstAddress As String
For Each sws In wb.Worksheets
' A 'begins-with' ('Left') comparison where 'StrComp' will return 0 if
' the strings are equal. Combined with 'vbTextCompare', it will
' ignore case i.e. 'CG=cg'.
If StrComp(Left(sws.Name, npLen), swsNameBegin, vbTextCompare) = 0 Then
Set srg = sws.Range(srgAddress)
Set slCell = srg.Cells(sCellsCount) ' the same for all strings
For ss = ssLower To ssUpper
Set sfCell = srg.Find( _
What:=SearchStrings(ss), _
After:=slCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows)
If Not sfCell Is Nothing Then ' string was found
FirstAddress = sfCell.Address ' to prevent an endless loop
Do
' Write to the Destination Worksheet.
dr = dr 1
dws.Cells(dr, 3).Value = sfCell.Value
dws.Cells(dr, 2).Value = sfCell.Offset(-3, 0).Value
dws.Cells(dr, 1).Value = sfCell.Offset(-5, 0).Value
' Find next string.
Set sfCell = srg.FindNext(sfCell)
' Note that in this case, 'sfCell' will never ever
' be 'Nothing' once it's 'something'. The 'Find' method
' doesn't 'know' where it found the first: it just finds
' the next even if it's the same (it goes round and round)
' i.e. if there is one cell to find,
' it will find it 'forever'.
' That's the reason behind comparing with the first address.
Loop While sfCell.Address <> FirstAddress
Set sfCell = Nothing ' reset for the next string
'Else ' string was not found
End If
Next ss
End If
Next sws
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Inform: useful for short and long operations.
MsgBox "Retrieved price tag information.", vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/361416.html