搜索特定的文本，比較，然后在VBA中復制和粘貼

Question

在Excel中，

我在Sheet1 / A欄上有大量信息，並且想搜索特定的文本（從單詞N1 * PE *到“〜N”之前的9個數字），

然后從正確的列表（Sheet2 / A列）中比較（Sheet1 / A列），然后將其粘貼到單獨的工作表（Sheet3 / A列）上。

這是一個例子：

在工作表1的A列中：（我下面有錯誤的信息）

EDI部* TE * 2658018518〜N1 * PE * ELMHUR

ST CENTER * XX * 564824568〜N4 * GREAT NECK * NY * 11023

N1 * PE 庫珀 XX * 333333333〜N4 *紐約* NY * 10077-5281〜REF * TJ * 133988001〜LX * 7111〜

您已經注意到，單詞ELMHURST已損壞。

我要完成的工作是根據示例列表（在Sheet2 / Column A上）替換錯誤的文本（在Sheet1 / Column A上），然后使用相同格式將其粘貼到Sheet3 / Column A->上。

這是（正確的）樣本信息列表（Sheet2 / A列）：

N1 * PE ELMHURST 中心 XX * 454545457

N1 * PE COOPER XX * 123457777

因此，結果應為：

在Sheet3 / A欄...

EDI部* TE * 2658018518〜N1 * PE * ELMHUR

ST中心* XX * 454545457〜N4 * GREEN NECK * NY * 11023

N1 * PE COOPER XX * 123457777〜N4 * NEW YORK * NY * 10077-5281〜REF * TJ * 133988001〜LX * 7111〜

以下代碼不完整。 因為它只能復制和粘貼在Sheet2列A上。

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 ..）。 這使得很難確定每個修復的行應在Sheet3上保留多長時間。 為了這個演示目的，我做出了一個任意決定，該長度應該與我要連接的兩個單元格中的第一個單元格的長度相同，但是在處理了許多行之后，該方法可能需要進行一些改進。 如果您需要使起始字符與現有字符匹配，則需要執行與此處相同的操作，並找到接下來的行起始字符的位置，並相應地划分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