如果找到匹配文本，則將值應用於其他工作簿

Question

以下代碼將打開一個.csv文件，在col B中查找「Trimmed Mean」，使用「Trimmed Mean」行作爲起點查找下一個「NC」值，並將「NC」右側的一個單元格複製到執行代碼的Workbook（Sheet 1 col A）中。

問題是代碼運行但該值未複製到工作表1。這可能只是一件小事，但我無法弄清楚那是什麼。謝謝你的幫助。

Const delim = vbTab 'for TAB delimited text files 


Sub ImportMultipleTextFiles() 

Dim wb As Workbook 
Dim sFile As Variant 
Dim LastRow As Long 
Dim rngCell As Range 
Dim varMyItem As String 

varMyItem = "NC" 

sFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...") 

Set wb = Workbooks.Open(Filename:=sFile) 

Application.ScreenUpdating = False 

wb.Sheets(1).Select 

LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row 
Debug.Print "LastRow = " & LastRow 

Set aCell = ActiveSheet.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _ 
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
    MatchCase:=False, SearchFormat:=False) 

Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row 
'wb.Sheets(1).Select 

For Each rngCell In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow) 
' Debug.Print ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow) 
    If InStr(rngCell, "NC") > 0 Then 
     Debug.Print rngCell.Row 
' 
     rngCell.Offset(0, 1).Copy Destination:=ThisWorkbook.ActiveSheet.Range("A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1) 

     Exit For 
    End If 
Next rngCell 


wb.Close SaveChanges:=False 

Set wb = Nothing 

Application.ScreenUpdating = True 

End Sub 

Answer 1

閱讀我的上述評論和審查我發送的鏈接。

我編輯了您的代碼以限定您的所有對象，並直接與每個對象一起工作。通過這種方式，您可以確保您的代碼每次都會對您渴望的對象起作用。

您可以通過行末尾的'***定義我編輯的行。

Const delim = vbTab 'for TAB delimited text files 

Sub ImportMultipleTextFiles() 

Dim wb As Workbook, wbThis As Workbook '*** 
Dim wsCopy As Worksheet, wsPaste As Worksheet '*** 
Dim sFile As Variant 
Dim LastRow As Long 
Dim rngCell As Range 
Dim varMyItem As String 

Set wbThis = ThisWorkbook '*** 
Set wsPaste = wbThis.Sheets("Sheet1") 'change name as needed '*** 

varMyItem = "NC" 

sFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...") 

Set wb = Workbooks.Open(Filename:=sFile) 
Set wsCopy = wb.Sheets(1) '*** 

Application.ScreenUpdating = False 

LastRow = wsCopy.Range("B" & Rows.Count).End(xlUp).Row '*** 
Debug.Print "LastRow = " & LastRow 

Set aCell = wsCopy.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _ 
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
    MatchCase:=False, SearchFormat:=False) '*** 

Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row 
'wb.Sheets(1).Select '*** 

For Each rngCell In wsCopy.Range("B" & aCell.Row & ":B" & LastRow) '*** 
' Debug.Print ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow) 
    If InStr(rngCell, "NC") > 0 Then 
     Debug.Print rngCell.Row 
' 
     rngCell.Offset(0, 1).Copy Destination:=wsPaste.Range("A" & wsPaste.Range("A" & wsPaste.Rows.Count).End(xlUp).Row + 1) '*** 

     Exit For 
    End If 
Next rngCell 


wb.Close SaveChanges:=False 

Set wb = Nothing 

Application.ScreenUpdating = True 

End Sub