1

住所の例「GILBERTAZ85234-4512」の一部を含む行があります。85234以外のすべてを削除したいので、数字以外のすべての文字を削除し、5桁の郵便番号のみを保持します。

1500以上のレコードがあるため、これはループで実行する必要があります。それほど問題がなければ、残っているスペースもすべて削除してください。

4

3 に答える 3

1

これは、RegExpおよびバリアント配列を使用すると最も効率的に実行されます（範囲ループは非常に遅くなる可能性があるため）

この記事から

Sub KillNums()
    Dim rng1 As Range
    Dim rngArea As Range
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngCalc As Long
    Dim objReg As Object
    Dim X()


    On Error Resume Next
    Set rng1 = Application.InputBox("Select range for the replacement of leading zeros", "User select", Selection.Address, , , , , 8)
    If rng1 Is Nothing Then Exit Sub
    On Error GoTo 0

    'See Patrick Matthews excellent article on using Regular Expressions with VBA
    Set objReg = CreateObject("vbscript.regexp")
    objReg.Pattern = "^.+?(\d+)\-.*$"


   'Speed up the code by turning off screenupdating and setting calculation to manual
   'Disable any code events that may occur when writing to cells
    With Application
        lngCalc = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Test each area in the user selected range

    'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
    For Each rngArea In Intersect(rng1, ActiveSheet.UsedRange).Areas
        'The most common outcome is used for the True outcome to optimise code speed
        If rngArea.Cells.Count > 1 Then
           'If there is more than once cell then set the variant array to the dimensions of the range area
           'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
            X = rngArea.Value2
            For lngRow = 1 To rngArea.Rows.Count
                For lngCol = 1 To rngArea.Columns.Count
                    'replace the leading zeroes
                    X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), "$1")
                Next lngCol
            Next lngRow
            'Dump the updated array back over the initial range
            rngArea.Value2 = X
        Else
            'caters for a single cell range area. No variant array required
            rngArea.Value = objReg.Replace(rngArea.Value, "$1")
        End If
    Next rngArea

    'cleanup the Application settings
    With Application
        .ScreenUpdating = True
        .Calculation = lngCalc
        .EnableEvents = True
    End With

    Set objReg = Nothing
End Sub
于 2012-06-08T01:32:59.040 に答える
0

簡単な方法は、セルを選択して、検索-置換（Ctrl + H）を選択することです。

最初に-*何も置き換えず、次に* ​​（空白を含めて）何も置き換えません。

これは、データが一貫してフォーマットされていることに依存しているため、結果を確認し、必要に応じて元に戻す/やり直しを使用します。

于 2012-06-07T16:09:43.170 に答える
0

他の場所のアドレスに「-」がない限り、これは機能するはずです。

更新：郵便番号に「-」が含まれていない場合にこれを変更しました

    Sub findZip()
Dim hyphen As String
Dim zip As String
    For Each cell In Range("A2:A1501")
        hyphen = InStr(1, cell, "-")
        If hyphen <> 0 Then
         zip = Trim(Mid(cell, hyphen - 5, 5))
         Else: zip = Right(Trim(cell), 5)
         End If
        cell.Offset(0, 1) = zip
    Next
End Sub
于 2012-06-07T16:53:01.597 に答える