Копирование значений в другую книгу, если найден соответствующий текст

Question

Следующий код открывает CSV-файл, находит «Trimmed Mean» в col B, использует строку «Trimmed Mean» в качестве отправной точки для поиска следующего «NC», значение в столбце B и копирует значение одной ячейки справа от «NC» в рабочую книгу, из которой выполняется код (лист 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