Искать определенный текст, сравнивать, а затем копировать и вставлять в VBA

Question

в Excel,

У меня есть куча информации на листе 1 / столбец A, и я хотел бы найти конкретный текст (начиная со слова N1 * PE * до 9 цифр перед "~ N"),

А затем сравните (Лист1 / Столбец А) из списка правильный (Лист2 / Столбец А) и затем вставьте его на отдельный лист (Лист3 / Столбец А).

Вот пример:

В листе 1, столбец A: (У меня НЕПРАВИЛЬНАЯ информация ниже)

EDI DEPARTMENT * TE * 2658018518 ~ N1 * PE * ELMHUR

ST CENTER * XX * 564824568 ~ N4 * БОЛЬШАЯ ШЕЯ * NY * 11023

N1 * PE COOPER XX * 333333333 ~ N4 * НЬЮ-ЙОРК * NY * 10077-5281 ~ REF * TJ * 133988001 ~ LX * 7111 ~

Как вы заметили, слово ELMHURST не используется.

Я хотел бы заменить неправильный текст (на листе 1 / столбец A) на основе списка образцов (на листе 2 / столбец A) и вставить его на листе 3 / столбец A -> , используя тот же формат .

Вот список образцов информации (ПРАВИЛЬНО) (Лист 2 / столбец A):

N1 * PE ELMHURST CENTER XX * 454545457

N1 * PE COOPER XX * 123457777

Итак, в результате должно быть:

In Sheet3 / Column A ...

ОТДЕЛ EDI * TE * 2658018518 ~ N1 * PE * ELMHUR

ST CENTER * XX * 454545457 ~ N4 * БОЛЬШАЯ ШЕЯ * NY * 11023

N1 * PE COOPER XX * 123457777 ~ N4 * НЬЮ-ЙОРК * NY * 10077-5281 ~ REF * TJ * 133988001 ~ LX * 7111 ~

Код ниже неполный. Как это можно только скопировать и вставить на листе 2 столбца А.

Option Explicit


Public Sub Transfer()

Dim lngRow As Long, lngWriteRow As Long, strTemp As String

Dim shtRaw As Worksheet, shtNew As Worksheet

'   Initialize

lngWriteRow = 1                     'The row we're writing to

Set shtRaw = Sheets("Sheet1")       'The raw data worksheet

Set shtNew = Sheets("Sheet2")       'The sheet with the concatenated text

For lngRow = 1 To shtRaw.UsedRange.Rows.Count

    If InStr(1, shtRaw.Cells(lngRow, 1), "N1*PE*", vbTextCompare) > 0 Then

'           Grab the end of this cell's text starting at N1*PE*

        strTemp = Mid(shtRaw.Cells(lngRow, 1), InStr(1, shtRaw.Cells
 (lngRow, 1), "N1*PE*", vbTextCompare))

'           Add the start of the next cell's text, up to the ~N


    strTemp = strTemp & Left(shtRaw.Cells(lngRow + 1, 1), InStr(1, shtRaw.Cells(lngRow + 1, 1), "~N", vbTextCompare))


'           Write the concatenated string to the other worksheet
            shtNew.Cells(lngWriteRow, 1) = strTemp

'           NEED TO DO SOMETHING HERE... COMPARE THE TEXT FROM THE LIST AND PASTE IT ON SHEET 3 COLUMN A            

'           Move down one row for the next time we write to the other sheet
        lngWriteRow = lngWriteRow + 1

    End If

Next lngRow

'Sort the NPIs

Sheets("Sheet2").Select

Range("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes


'   Clean up memory

Set shtRaw = Nothing

Set shtNew = Nothing


End Sub

Заранее большое спасибо ...

Answer 1

ниже может работать. Кажется, что у ваших заменяющих значений произвольно отсутствуют * и пробелы по сравнению с оригиналами (то есть PE * ELM .. vs PEELM ..). Это затрудняет определение длины каждого отремонтированного ряда на листе 3. Я принял произвольное решение: она должна быть той же длины, что и первая из двух ячеек, которые я объединяю для целей этой демонстрации, но этот метод может нуждаться в некотором уточнении после обработки многих строк. Если вам нужно, чтобы начальные символы совпадали с существующими, вам нужно сделать что-то похожее на то, что я сделал здесь, и найти позиции следующих начальных символов строки и соответственно разделить NewCombinedString.

Sub FixSheet1ColumnA()
    Dim i As Integer
    i = 1
    Do While Sheet1.Range("A" & i) <> ""
        'Combined adjoining rows to account for values which overlap between rows
        Dim Cell1Value As String
        Dim Cell2Value As String
        Dim CombinedString As String
        'The upper of the rows should come from whatever has been processed onto
        'Sheet3 except for the very first row which has to come from Sheet1
        If i = 1 Then Cell1Value = Sheet1.Range("A" & i) Else Cell1Value = Sheet3.Range("A" & i)
        Cell2Value = Sheet1.Range("A" & i + 1)
        CombinedString = Cell1Value & Cell2Value
        Dim SearchString As String
        'Strip the * and space characters out of the string to search it as there
        'seem to be random extras of these in Sheet1 column A
        SearchString = Replace(Replace(CombinedString, " ", ""), "*", "")
        'Cycle through Sheet2 column A to see if there are any matches for the
        'first n-9 digits of each value there, also removing * and space characters
        'for consistency
        Dim j As Integer
        j = 1
        Do While Sheet2.Range("A" & j) <> ""
            Dim ReplacementString As String
            ReplacementString = Sheet2.Range("A" & j)
            Dim FindString As String
            FindString = Replace(Replace(ReplacementString, " ", ""), "*", "")
            'determine if the first n-9 characters of the given Sheet2 value are found
            Dim SubStringPosition As Integer
            SubStringPosition = InStr(1, SearchString, Left(FindString, Len(FindString) - 9))
            If SubStringPosition <> 0 Then
                'Find the tilde that immediately precedes the string to be replaced
                Dim FirstTildePosition As Integer
                FirstTildePosition = InStr(SubStringPosition, CombinedString, "~")
                'Find the tilde that follows it
                Dim SecondTildePosition As Integer
                SecondTildePosition = InStr(FirstTildePosition + 1, CombinedString, "~")
                Dim NewCombinedString As String
                NewCombinedString = Left(CombinedString, FirstTildePosition) _
                    + ReplacementString _
                    + Right(CombinedString, Len(CombinedString) - SecondTildePosition + 1)
                Exit Do
            End If
            j = j + 1
        Loop
        'Populate the first part of potentially fixed CombinedString into Sheet3
        If i = 1 Then Sheet3.Range("A" & i) = Left(NewCombinedString, Len(Cell1Value))
        Sheet3.Range("A" & i + 1) = Right(NewCombinedString, Len(NewCombinedString) - Len(Cell1Value))
        i = i + 1
    Loop
End Sub