Nicht in der Lage, ein Muster mit VBA zu extrahieren

Question

Ich habe mehrere Zeilen in einer einzigen Zelle, über eine Spalte. Ich möchte den folgenden Kommentar und das Datum extrahieren. Jedem Datum ist ?#+@ vorangestellt. Für z.

Hello ?#+@2013 12 31T06:27:58+0000Great post ?#+@2013 12 31T06:33:23+0000Awesome post Thanks?#+@2013 12 31T06:49:38+0000 

Also, ich mag hello und 2013 12 31T06:27:58+0000 zusammen Ergebnisblatt extrahieren und so weiter ..

stieß ich auf einem VBA-Code für das gleiche. Es gibt jedoch keine Ausgabe.

Der Code ist wie folgt:

Sub datascrub() 

On Error Resume Next 
    Set SourceSheet = ActiveSheet 
    Set TargetSheet = ActiveWorkbook.Sheets("Results") 
    If Err = 0 Then 
     Worksheets("Results").Delete 
    End If 

    Worksheets.Add 
    ActiveSheet.Name = "Results" 
    Set TargetSheet = ActiveSheet 
    Cells(1, 1).Value = "Found Codes" 
    Cells(1, 1).Font.Bold = True 
    iTargetRow = 2 

    SourceSheet.Select 
    Selection.SpecialCells(xlCellTypeLastCell).Select 
    Range(Selection, Cells(1)).Select 

    For Each c In Selection.Cells 
     If c.Value Like "?#+@" Then 
      sRaw = c.Value 
      iPos = InStr(sRaw, "?#+@") 
      Do While iPos > 0 
       If iPos < 4 Then 
        sRaw = " " & sRaw 
        iPos = iPos + 4 
       End If 
       sTemp = Mid(sRaw, iPos, 4) 
       sRaw = Mid(sRaw, iPos + 4, 24) 
       If sTemp Like "?#+@" Then 
        TargetSheet.Cells(iTargetRow, 1) = sTemp 
        iTargetRow = iTargetRow + 1 
       Else 
        sRaw = Mid(sTemp, 4, 5) & sRaw 
       End If 
       iPos = InStr(sRaw, "?#+@") 
      Loop 
     End If 
    Next c 
End Sub 

Jede Hilfe würde geschätzt.

Answer 1

Der folgende Code wird hoffentlich tun, was Sie wollen:

Sub datascrub() 

    On Error Resume Next 
    Set SourceSheet = ActiveSheet 
    Set TargetSheet = ActiveWorkbook.Sheets("Results") 
    If Err = 0 Then 
     Worksheets("Results").Delete 
    End If 

    Worksheets.Add 
    ActiveSheet.Name = "Results" 
    Set TargetSheet = ActiveSheet 
    Cells(1, 1).Value = "Found Codes" 
    Cells(1, 1).Font.Bold = True 
    iTargetRow = 2 

    SourceSheet.Select 
    Selection.SpecialCells(xlCellTypeLastCell).Select 
    Range(Selection, Cells(1)).Select 

    For Each c In Selection.Cells 
     sRaw = c.Value 
     iPos = InStr(sRaw, "?#+@") 
     Do While iPos > 0 

      'Use the following line if you want message?#+@date in column A 
      TargetSheet.Cells(iTargetRow, 1) = Left(sRaw, iPos + 27) 

      'Or use the following two lines if you want the message in column A and the date in column B 
      'TargetSheet.Cells(iTargetRow, 1) = Left(sRaw, iPos - 1) 
      'TargetSheet.Cells(iTargetRow, 2) = Mid(sRaw, iPos + 4, 24) 


      iTargetRow = iTargetRow + 1 

      sRaw = Mid(sRaw, iPos + 28) 
      iPos = InStr(sRaw, "?#+@") 
     Loop 
    Next c 
End Sub 

Answer 2

Das Problem ist mit Like: Es wird nicht die wörtliche überein „? # + @“, Da mehrere dieser Zeichen haben eine besondere Bedeutung für Like.

Ich würde vorschlagen:

• Ihre Variablen deklarieren und Option Explicit an der Spitze setzen variable Erklärung zu verlangen. Dies ist eine gute Angewohnheit und wird helfen, offensichtliche Fehler zu beseitigen;
• Fehler nicht länger als nötig unterdrücken. Setzen Sie On Error Goto 0, sobald Sie sie nicht mehr unterdrücken müssen. Auch dies wird Ihnen helfen, den Code leichter zu beheben.
• Verwenden Sie Split zum Ergreifen von Teilen einer Zeichenfolge;
• Nicht Like zu verwenden: wie in den Kommentaren erwähnt mehrere Zeichen entkommen müssten, aber noch wichtiger ist, wie Sie die Zeichenfolge brechen wollen, können Sie schnellere Ergebnisse erhalten mit Split
• Konvertieren der extrahierten Zeitstempel Excel Datum/Zeitformat.

Hier ist der vorgeschlagene Code ist:

Option Explicit 

Sub datascrub() 
    Dim SourceSheet As Worksheet 
    Dim TargetSheet As Worksheet 
    Dim iTargetRow As Long 
    Dim sDate As String 
    Dim c As Range 
    Dim line, pair 

    Set SourceSheet = ActiveSheet 
    On Error Resume Next 
     Worksheets("Results").Delete 
    On Error GoTo 0 
    Worksheets.Add 
    ActiveSheet.Name = "Results" 
    Set TargetSheet = ActiveSheet 
    Cells(1, 1).Value = "Found Codes" 
    Cells(1, 1).Font.Bold = True 
    iTargetRow = 2 

    SourceSheet.Select 
    Selection.SpecialCells(xlCellTypeLastCell).Select 
    Range(Selection, Cells(1)).Select 

    For Each c In Selection.Cells 
     For Each line In Split(c.Value, "+0000") 
      If line = "" Then Exit For 
      pair = Split(line, "?#+@") 
      sDate = Replace(Replace(pair(1), " ", "-"), "T", " ") 
      TargetSheet.Cells(iTargetRow, 1) = pair(0) 
      TargetSheet.Cells(iTargetRow, 2) = CDate(sDate) 
      iTargetRow = iTargetRow + 1 
     Next line 
    Next c 
End Sub 

Für die Beispieldaten in der Frage, wäre es produzieren:

| Found Codes   |     | 
| Hello    | 31/12/2013 06:27 | 
| Great post   | 31/12/2013 06:33 | 
| Awesome post Thanks | 31/12/2013 06:49 | 

Answer 3

Ich glaube, das ist das, was nach der du bist:

Option Explicit 

Sub datascrub() 
    Dim SourceSheet As Worksheet, TargetSheet As Worksheet 
    Dim iArr As Long 
    Dim cell As Range 
    Dim tempArr As Variant 

    Set TargetSheet = GetWorkSheet(ThisWorkbook, "Results") '<--| get/set "results" sheet 
    With TargetSheet 
     .Cells(1, 1).Value = "Found Codes" 
     .Cells(1, 1).Font.Bold = True 
    End With 

    With ThisWorkbook.Worksheets("Source") '<--| explicitly reference "Source" sheet (change "Source" as per your actuale source sheet name) 
     With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<--| consider only text values in column "A" (or change "A" as per your possible different needs) 
      .Replace What:="+0000", Replacement:="+0000||", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True '<--| "mark" the wanted records by inserting "||" after each date end (I assume it always ends with "+0000") 
      For Each cell In .Cells '<--| loop through considered cells 
       tempArr = Split(cell.Value2, "||") '<--| fill the temporary array with the current cell content records 
       For iArr = LBound(tempArr) To UBound(tempArr) - 1 '<--| loop through the temporary array.. 
        TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Offset(1) = Split(tempArr(iArr), "?#+@")(0) & " " & Split(tempArr(iArr), "?#+@")(1) '<--| ... and write results 
       Next iArr 
      Next cell 
      .Replace What:="||", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True '<--| remove the "mark" we inserted at the beginning 
     End With 
    End With 
End Sub 

Function GetWorkSheet(wb As Workbook, shtName As String) As Worksheet 
    On Error Resume Next 
    Set GetWorkSheet = wb.Worksheets(shtName) 
    If GetWorkSheet Is Nothing Then 
     Set GetWorkSheet = wb.Worksheets.Add 
     ActiveSheet.Name = shtName 
    Else 
     GetWorkSheet.Cells.ClearContents 
    End If 
End Function 

ändern Sie einfach die Referenzen nach Ihren Bedürfnissen (siehe Kommentare)

sollten Sie brauchen eine Trennlinie zwischen jedem „Datum & Inhalt“ Zeichenfolge setzen oder ihre Reihenfolge zu umkehren oder sie einfach in zwei verschiedenen Zellen setzen einstellen:

TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Offset(1) = Split(tempArr(iArr), "?#+@")(0) & " " & Split(tempArr(iArr), "?#+@")(1)