データregex vbaを無効にするコードの2回目の実行を停止する方法？

Question

以下のコードは、6chr、5chr、4chr、5 + chrのパターンに基づいて1セルを3列または4列に分割します。以下はまた、すべての開いているブックで使用可能で、ユーザーの選択から作業する必要があります。

セルの最初の分割が完了した後で誤って再度実行すると、データが上書きされるというバグを修正するにはどうすればよいですか？上記のため

クラスモジュール

Option Explicit 
'Rename this Class Module cFabric 
Private pStyle As String 
Private pFabric As String 
Private pColour As String 
Private pSize As String 

Public Property Get Style() As String 
    Style = pStyle 
End Property 
Public Property Let Style(Value As String) 
    pStyle = Value 
End Property 

Public Property Get Fabric() As String 
    Fabric = pFabric 
End Property 
Public Property Let Fabric(Value As String) 
    pFabric = UCase(Value) 
End Property 

Public Property Get Colour() As String 
    Colour = pColour 
End Property 
Public Property Let Colour(Value As String) 
    pColour = Value 
End Property 

Public Property Get Size() As String 
    Size = pSize 
End Property 
Public Property Let Size(Value As String) 
    pSize = Value 
End Property 

正規モジュール

Option Explicit 
Sub Fabrics() 

    Dim wsSrc As Workbook, wsRes As Workbook 
    Dim vSrc As Variant, vRes As Variant, rRes As Range 
    Dim RE As Object, MC As Object 

    Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?" 
     'Group 1 = style 
     'Group 2 = fabric 
     'Group 3 = colour 
     'Group 4 = size 
    Dim colF As Collection, cF As cFabric 
    Dim I As Long 
    Dim S As String 
    Dim V As Variant 

'Set source and results worksheets and ranges 
Set wsSrc = ActiveWorkbook 
Set wsRes = ActiveWorkbook 
    Set rRes = wsRes.Application.Selection 

'Read source data into array 
vSrc = Application.Selection 

'Initialize the Collection object 
Set colF = New Collection 

'Initialize the Regex Object 
Set RE = CreateObject("vbscript.regexp") 
With RE 
    .Global = False 
    .MultiLine = True 
    .Pattern = sPat 

'Test for single cell 
If Not IsArray(vSrc) Then 
    V = vSrc 
    ReDim vSrc(1 To 1, 1 To 1) 
    vSrc(1, 1) = V 
End If 

    'iterate through the list 
For I = 1 To UBound(vSrc, 1) 
    S = vSrc(I, 1) 
    Set cF = New cFabric 
    If .test(S) = True Then 
     Set MC = .Execute(S) 
     With MC(0) 
      cF.Style = .submatches(0) 
      cF.Fabric = .submatches(1) 
      cF.Colour = .submatches(2) 
      cF.Size = .submatches(3) 
     End With 
    Else 
     cF.Style = S 
    End If 
    colF.Add cF 
Next I 
End With 

'create results array 
'Exit if no results 
If colF.Count = 0 Then Exit Sub 

ReDim vRes(1 To colF.Count, 1 To 4) 

'Populate the rest 
I = 0 
For Each V In colF 
    I = I + 1 
    With V 
     vRes(I, 1) = .Style 
     vRes(I, 2) = .Fabric 
     vRes(I, 3) = .Colour 
     vRes(I, 4) = .Size 
    End With 
Next V 

'Write the results 
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) 
    rRes.Value = vRes 

End Sub 

クレジットは、プロジェクトのために@Ronローゼンフェルドに行きます！スプレッドシートに出力し、あなたのコードで

Answer 1

1つのwない場合は、エントリが以前に分割されている場合の結果ラインが通過した場合 その後、

• を次のようにregex.testが失敗した場合である
  • を伝えるためにAYは、その項目は、以前
  • を分割されています、それはあなたがあなたの元のデータを上書きしていなかった場合は、この多くのを回避することができることを

空白、または不正な形式のエントリ注意です。監査とデバッグの両方の目的でデータを上書きしないことをお勧めしますが、変更することができない場合は以下のようにしてください。

不正なエントリが最初にチェックされたロジックの一部を少し変更するだけで済みます。同様に「可能な」結果配列をvSrcに読み込んで、比較する潜在的に分割されたデータを得る：

Option Explicit 
Sub Fabrics() 
    'assume data is in column A 
    Dim wsSrc As Worksheet, wsRes As Worksheet 
    Dim vSrc As Variant, vRes As Variant, rRes As Range 
    Dim RE As Object, MC As Object 
    Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?" 
     'Group 1 = style 
     'Group 2 = fabric 
     'Group 3 = colour 
     'Group 4 = size 
    Dim colF As Collection, cF As cFabric 
    Dim I As Long 
    Dim S As String 
    Dim V As Variant 

'Set source and results worksheets and ranges 
Set wsSrc = ActiveSheet 
Set wsRes = ActiveSheet 
    Set rRes = Selection 

'Read source data into array 
vSrc = Selection.Resize(columnsize:=4) 

'Initialize the Collection object 
Set colF = New Collection 

'Initialize the Regex Object 
Set RE = CreateObject("vbscript.regexp") 
With RE 
    .Global = False 
    .MultiLine = True 
    .Pattern = sPat 

    'iterate through the list 

'Test for single cell 
If Not IsArray(vSrc) Then 
    V = vSrc 
    ReDim vSrc(1 To 1, 1 To 1) 
    vSrc(1, 1) = V 
End If 

For I = 1 To UBound(vSrc, 1) 
    S = vSrc(I, 1) 
    Set cF = New cFabric 
    If .test(S) = True Then 
     Set MC = .Execute(S) 
     With MC(0) 
      cF.Style = .submatches(0) 
      cF.Fabric = .submatches(1) 
      cF.Colour = .submatches(2) 
      cF.Size = .submatches(3) 
     End With 

    ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then 
     cF.Style = S 
    Else 
     cF.Style = vSrc(I, 1) 
     cF.Fabric = vSrc(I, 2) 
     cF.Colour = vSrc(I, 3) 
     cF.Size = vSrc(I, 4) 
    End If 
    colF.Add cF 
Next I 
End With 

'create results array 
'Exit if not results 
If colF.Count = 0 Then Exit Sub 

ReDim vRes(1 To colF.Count, 1 To 4) 

'Populate 
I = 0 
For Each V In colF 
    I = I + 1 
    With V 
     vRes(I, 1) = .Style 
     vRes(I, 2) = .Fabric 
     vRes(I, 3) = .Colour 
     vRes(I, 4) = .Size 
    End With 
Next V 

'Write the results 
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) 
With rRes 
    .Clear 
    .NumberFormat = "@" 
    .Value = vRes 
    .EntireColumn.AutoFit 
End With 

End Sub 

Answer 2

、あなたは空の文字列

I = 0 
For Each V In colF 
    I = I + 1 
    With V 
     vRes(I, 1) = .Style 
     If len(.Fabric) > 0 then 
      vRes(I, 2) = .Fabric 
      vRes(I, 3) = .Colour 
      vRes(I, 4) = .Size 
     End If 
    End With 
Next V 

Answer 3

前の正規表現/クラスメソッドを無視、

Option Explicit 

Sub Fabrics_part_Deux() 
    Dim a As Long, b As Long 

    With Worksheets("Sheet1") 
     If .AutoFilterMode Then .AutoFilterMode = False 
     With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 3)) 
      With .Columns("B") 
       .Offset(1, 0).Replace what:=Chr(32), replacement:=vbNullString, lookat:=xlPart 
      End With 
      .AutoFilter field:=2, Criteria1:="<>" 
      .AutoFilter field:=3, Criteria1:="" 
      With .Resize(.Rows.Count - 1, 1).Offset(1, 1) 
       If CBool(Application.Subtotal(103, .Cells)) Then 
        With .SpecialCells(xlCellTypeVisible) 
         For a = 1 To .Areas.Count 
          With .Areas(a).Cells 
           .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _ 
            FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1), Array(15, 2)) 
           For b = 1 To .Rows.Count 
            .Cells(b, 2) = UCase$(.Cells(b, 2).Value2) 
            If CBool(InStr(1, .Cells(b, 4).Value2, Chr(47), vbBinaryCompare)) Then 
             .Cells(b, 4) = Trim(Split(.Cells(b, 4), Chr(47))(1)) 
            End If 
           Next b 
          End With 
         Next a 
        End With 
       End If 
      End With 
     End With 
     If .AutoFilterMode Then .AutoFilterMode = False 
    End With 
End Sub 

をチェックする必要があります