VBAを使用してパターンを抽出できません

Question

1つのセルに複数の行があります。私はそれに続くコメントと日付を抽出したい。各日付の前には、?#+@が付いています。たとえば。だから、

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

、私は同じのためのVBAコードに出くわした結果シートで一緒にhelloと2013 12 31T06:27:58+0000を抽出したいというように。..

。しかし、出力は出ていません。

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 

任意の助けが理解されるであろう次のよう

コードです。

Answer 1

次のコードでは、うまくいけば、あなたがやりたいことになります。

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

を問題はLikeである：それは「？＃+ @」リテラル一致しません、これらの文字のいくつかは、特別な意味のために持っているので、 Like。

私がすることをお勧め：あなたの変数を宣言し、変数の宣言を必要とするように上部にOption Explicitを置く

• 。これは良い習慣であり、明らかな誤りを排除するのに役立ちます。
• エラーを必要以上に抑止しないようにします。これ以上抑制する必要がなくなればすぐにOn Error Goto 0を入力してください。繰り返しますと、コードのトラブルシューティングをより簡単に行うことができます。
• 文字列の部分を取得するのにSplitを使用します。
• Like使うまでもありません：コメントで述べたように、あなたは、文字列を分割したいと、あなたは/ Excelの日付に抽出されたタイムスタンプを変換Split
• で速い結果を得る、もっと重要なのは、いくつかの文字をエスケープする必要があるだろうが時間フォーマット。ここで

示唆したコードです：問題のサンプルデータについては

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 

、それが生成します：

| 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

私は、これはあなたが後にしているものであると信じています：

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 

あなたのニーズに応じて参照を変更してください（コメントを参照）

あなたは、単に調整し、それぞれ「日付&内容」の文字列の間でいくつかの区切り文字を入れたり、順序を反転または2個の異なる細胞でそれらを配置する必要がありますする必要があります

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