代码之家 › 专栏 › 技术社区 › Eric

我有邮政编码替换问题Excel VBA

vba excel

Eric · 技术社区 · 11 月前

Macro需要替换C列中的一组邮政编码。对于其他邮政编码,请替换它们,并在C列底部添加另一个邮政编码(列表中的1个邮政编码将变为2个邮政编码)。然后复制所有的邮政编码,以便粘贴到另一个应用程序中。

我是一个完全的编程新手(20年来没有做过任何事情,即使是最小的涉猎)。所以我的代码是一个记录宏的弗兰肯斯坦,从网站上复制粘贴的代码,以及我所做的草率编辑。

我遇到了两个问题:

取代单一邮政编码的部分似乎运行良好。主要问题似乎是,当试图查找是否有需要变为2个邮政编码的邮政编码时,如果文档中不存在其中一个邮政编码,宏似乎会崩溃。此列表中的数据每天都在变化,有时这些邮政编码不会出现。如果它试图查找、替换和添加的邮政编码不存在,我需要它继续工作。
在excel中,邮政编码似乎是一场噩梦(由于前导0)。我不明白为什么我正在做的某些事情会放弃领先的0,而不是其他事情。

我试着录制一个宏来找到我需要的邮政编码并替换它们。如果我需要修改的所有可能的邮政编码都在文档中,它的工作原理与预期完全一致,但如果不更改其余邮政编码并为我复制列,它就会崩溃。

我曾尝试删除初始宏的“查找”部分,只留下“替换”部分(我认为这与我试图做的事情是多余的)。这似乎没有什么区别。

我曾尝试添加if-then,因为我怀疑它们可能是一种解决方案,但我无法理解在语法的哪个位置可以放什么样的东西,以及如何利用它们来做我需要的事情。

这是代码

Sub Zipcode1()
    'Replaces Uselss Zip Codes with Delivery Offices
    Range("c:c").Replace What:="06042", Replacement:="'06040"
    Range("c:c").Replace What:="06610", Replacement:="'06602"
    Range("c:c").Replace What:="06013", Replacement:="'06013"
    Range("c:c").Replace What:="06850", Replacement:="'06854"
    Range("c:c").Replace What:="06447", Replacement:="'06424"
    
    'Replace 06851 > 06854 and 06856
'        Cells.Find(What:="06851", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
'        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
'        False, SearchFormat:=False).Activate
'    Cells.Replace What:="06851", Replacement:="'06854", LookAt:=xlPart, _
'        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
'        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'    Selection.End(xlDown).Select
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
'    ActiveCell.FormulaR1C1 = "'06856"
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select

'        Cells.Find(What:="06851", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
'        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
'        False, SearchFormat:=False).Activate
    If Range(C, C).Value = "06851" Then
    Cells.Replace What:="06851", Replacement:="06854", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True, FormulaVersion:=xlReplaceFormula2
    Range("C2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    ActiveCell.FormulaR1C1 = "6856"
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "06856"
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    End If
     
        'Replace 06910 > 06907 and 06902
'        Cells.Find(What:="06910", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
'        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
'        False, SearchFormat:=False).Activate
'    Cells.Replace What:="06910", Replacement:="'06902", LookAt:=xlPart, _
'        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
'        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'    Selection.End(xlDown).Select
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
'    ActiveCell.FormulaR1C1 = "'06907"
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    Cells.Replace What:="06910", Replacement:="06902", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True, FormulaVersion:=xlReplaceFormula2
    Range("C2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    ActiveCell.FormulaR1C1 = "6907"
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "06907"
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
        
    'Realigns C
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("InitialContactTable[[#Headers],[Facili0y ZIP Code]]").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
     
    'Obliterates empty rows so they don't get copied
    Dim rng As Range
    Dim i As Long
    Set rng = ActiveSheet.UsedRange
    For i = rng.Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(rng.Rows(i)) = 0 Then
            rng.Rows(i).EntireRow.Delete
        End If
    Next i
    
    'Copies Zipcodes
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
End Sub

1 回复 | 直到 11 月前

Tim Williams 11 月前

试试这个:

Sub PerformZipReplacements()

    Dim lc As ListColumn
    
    Set lc = ActiveSheet.ListObjects("InitialContactTable").ListColumns("Facility ZIP Code")
    
    ReplaceInColumn lc, "blah1", "new1"  'one ZIP to one  ZIP
    
    ReplaceInColumn lc, "blah4", "new4A", "new4B" 'one ZIP to two ZIPs
    
    ReplaceInColumn lc, "notThere", "newVal"   'test non-existant value
    
    ReplaceInColumn lc, "blah6", "new6A", "blah6", "new6C" 'one ZIP to three ZIPs (one same)
    
End Sub


Sub ReplaceInColumn(lc As ListColumn, findVal As String, _
                                ParamArray newVals() As Variant)
    
    Dim lb As Long, i As Long, r As Long, data As Variant
    
    lc.Range.NumberFormat = "@" 'ensure "Text" format
    data = lc.Range.Value 'read to array for performance

    'loop backwards over data to avoid issues with inserted rows
    For r = UBound(data, 1) To 1 Step -1
        If data(r, 1) = findVal Then 'match?
            For i = 0 To UBound(newVals)
                If i = 0 Then  'first replacement?
                    lc.Range.Cells(r).Value = newVals(i)
                Else
                    lc.Parent.ListRows.Add r + (i - 1)       'add a row to the list
                    lc.Range.Cells(r + i).Value = newVals(i) 'add the ZIP to the new row
                End If
            Next i
        End If
    Next r
End Sub

我的测试表“之前”和“之后”: