Excel VBA 数据替换

 

源文件.xlsx 有两列数据，一个是原始值，一列是替代值

根据实际数据行修改

nValueCount = 597

修改后的数据填充为了蓝色

---------------------------------------

Private Sub MyReplace()
Application.ScreenUpdating = False
Dim MyPath$, MyFile$, sht As Worksheet

MyPath = ThisWorkbook.Path & "\"
MyFile = Dir(MyPath & "*.xls")
Dim nRow As Long
Dim nColumn As Long

Dim SheetName As String
Dim cellValue As String
Dim nValueCount As Integer
nValueCount = 597
Dim oldValue()
Dim newValue()

ReDim oldValue(nValueCount)
ReDim newValue(nValueCount)

Dim sht2

With Workbooks.Open(ThisWorkbook.Path & "\源文件.xlsx")
  Set sht2 = .Worksheets(1)
        With sht2
        For i = 2 To nValueCount + 2
           oldValue(i - 2) = .Cells(i, 1)
           newValue(i - 2) = .Cells(i, 2)
        Next
        End With
    .Close
End With

Dim cellRange As Range
Dim curCellRange As Range
Dim Hasf As Variant

Do While MyFile <> ""
    If MyFile <> ThisWorkbook.Name And MyFile <> "源文件.xlsx" Then
        With Workbooks.Open(MyPath & MyFile)
            For Each sht In .Worksheets
                With sht
                  Set cellRange = sht.UsedRange
                 
                    SheetName = sht.Name
                    nRow = cellRange.Rows.Count
                    nColumn = cellRange.Columns.Count
                   
                    For i = 1 To nColumn
                      For j = 1 To nRow
                         Set curCellRange = .Cells(j, i)
                        
                            If curCellRange.HasFormula Then
                                'Hasf = Rng.Formula
                                Exit For
                            Else
                                'Hasf = ""
                            End If

                           cellValue = .Cells(j, i)
                       
                           For k = 0 To nValueCount
                              If oldValue(k) = cellValue Then
                                .Cells(j, i) = newValue(k)
                                 curCellRange.NoteText 'Joker'
                                 curCellRange.Interior.Color = RGB(0, 0, 255)
                                 Exit For
                              End If
                           Next
                          
                         '.Cells(j, i)
                      Next
                    Next

                End With
            Next
        '.Save
        '.Close True
        End With
    End If
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

 ---------------------------------------------------------------

希望对经常用Excel处理数据的人有用。