Сравнение содержимого ячеек столбца с текстовым файлом и копирование соответствующих строк в другую книгу VBA

Question

Я понятия не имею, что я делаю, и если вам хочется кричать на меня, это круто.

Мне интересно, как бы я проверил значения каждой ячейки в столбце D на листе, называемом PriceList, со значениями в текстовом файле ItemNumber.txt.

Если содержание ячеек в столбце равно одному из значений в указанном текстовом файле я хочу, чтобы скопировать строку и вставьте его в sheet1 ....

Option Explicit 



Sub CompareValue() 

Dim FileNum As Integer 
Dim DataLine As String 
Dim cel As Range 
Dim celString As String 



' Select file to be opened 
    FileNum = FreeFile() 
    Open "C:\Users\jreinhold\Documents\ItemNumbers.txt" For Input As #FileNum 



    Set myRange = Range("D:D") 


      For i = 1 To myRange.Rows.Count 'loop through rows by using i as a cell reference 
      Do While Not EOF(FileNum) 'run input from file while not end of file 
      Line Input #FileNum, DataLine 'input line data into DataLine 


      ' Check value of cell against read in data 
      If InStr(DataLine, myRange.Cells("D", i).Value) = 0 Then 'compare DataLine to cell i 
       ' Copy Row Where match resides 
       DataLine = DataLine + 1 'if value of comparison is 0 add 1 to data line and get next line in text file 

      Loop 'Loop back around and plus next line for the data from the file in and check values against cell i again 
      End If 'end If once value for comparison is true 
      Source.Rows(c.Row).Copy Target.Rows(i) ' Copy row 
      Sheets("Sheet1").Paste ' Paste row into Sheet1 
       i = i + 1   ' add 1 to i in order to continue to next cell in column 
     Next i 'check next cell for the data inputs using the same code. 



Wend 

End Sub

Answer 1

Попробуйте это:

Sub CompareValue() 
Dim mainWS As Worksheet, dataWS As Worksheet, txtWS As Worksheet 
    Dim FileNum&, i&, j& 
    Dim DataLine As String, celString$ 
    Dim cel As Range, myRange As Range 
    Dim ranOnce As Boolean 

    ranOnce = False ' Check if we've added a line to your new sheet 


    Dim fileName$, filePath$, fullFile$ 
    filePath = "C:\Users\bWayne\" 
    fileName = "myTextDoc.txt" 
    fullFile = filePath & fileName 

    Set dataWS = Sheets("Data") ' Rename this, this sheet has your column D with the values to check 
    Set mainWS = Sheets("Sheet1") ' This is where the row from DATA will be copied to, if a match is found in the text file. 

    ' This will call a sub that will put the text into the temp sheet 
    TextFile_PullData fullFile, mainWS 
    Set txtWS = Sheets(Left(fileName, WorksheetFunction.Search(".", fileName) - 1)) 

' Now we have the text file informaiton in a sheet. So just loop through the cells in "Data" and check if there's a match in the text 
Dim lastRow& 
lastRow = dataWS.Cells(dataWS.Rows.Count, 4).End(xlUp).Row 
Set myRange = dataWS.Range("D1:D" & lastRow) ' edit this as necessary 
For Each cel In myRange 
    If WorksheetFunction.CountIf(txtWS.Range("A1:A" & txtWS.UsedRange.Rows.Count), cel.Value) > 0 Then 
     ' Since we found a match, copy the entire row to "Sheet1" 
     Dim newLastRow& 
     newLastRow = mainWS.Cells(mainWS.Rows.Count, 4).End(xlUp).Row 

     If ranOnce Then newLastRow = newLastRow + 1 
     ranOnce = True 
     mainWS.Rows(newLastRow).EntireRow.Value = cel.EntireRow.Value 
    End If 
Next cel 

End Sub 
Sub TextFile_PullData(fileName As String, mySheet As Worksheet) 

Workbooks.OpenText fileName:=fileName, _ 
     Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ 
     xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ 
     Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _ 
     TrailingMinusNumbers:=True 

ActiveSheet.Copy after:=mySheet 

End Sub 

Вместо того, чтобы идти построчно, я только что импортировали файл текста в Excel, и я просто делаю CountIf(), чтобы увидеть, если есть совпадение. Если это так, скопируйте эту строку на новый лист. Обратите внимание, что вы, вероятно, захотите изменить листы, поскольку мне не ясно, куда вы хотите, чтобы данные шли. Это должно помочь вам двигаться! Я рекомендую пройти с F8, чтобы убедиться, что он работает.

Редактировать: у вас были какие-то петли, которые я, возможно, не рассматривал, поэтому дайте мне знать, если я что-то упустил.