我對 VBA 真的很陌生，我正在嘗試撰寫一個 Makro，它通過一個包含兩列的串列并替換第二列中的一些文本。我想結合使用通配符和二維陣列中的值來搜索值。
所以這就是我想要完成的。我有一個檔案，其中所有口袋妖怪卡按它們所在的集合分隔在不同的作業表中。那里有 2 列稱為“名稱”和“德國名稱”。現在我創建了另一個包含所有卡片及其對應名稱和德語名稱的作業表。在該作業表中，我創建了一個二維陣列。這絕對沒問題。然后我有一些回圈在里面，我有這行代碼
Worksheets(table).Cells(otherI, 2).Value = Replace(Worksheets(table).Cells(otherI, 2).Value, " * " & allArray(i, 0) & " * ", " * " & allArray(i, 1) & " * ")
某處存在問題，我找不到任何解決方案。因此，即我在兩列中都有條目“Bulbasaur Lv.5”，現在我想將第二列中的“Bulbasaur”替換為對應的德語“Bisasam”，但不能觸及“Lv.5”。
如果有人可以提供解決方案，我將不勝感激。以防萬一這是我到目前為止的整個腳本。
Option Explicit
Sub firstMakro()
'Variables
Dim allSize As Integer
Dim allArray()
Dim allI As Integer
allI = 1
Dim otherSize As Integer
Dim otherI As Integer
otherI = 1
Dim i As Integer
Dim table As Integer
table = 2
'Create Array
allSize = WorksheetFunction.CountA(Worksheets("All_Pokemons").Columns(1))
ReDim allArray(allI To allSize, 1)
Do
allArray(allI, 0) = Worksheets("All_Pokemons").Cells(allI, 1).Value
allArray(allI, 1) = Worksheets("All_Pokemons").Cells(allI, 2).Value
allI = allI 1
Loop Until allI > allSize
MsgBox ("Array created")
'Replace Entries
For i = LBound(allArray, 1) To UBound(allArray, 1)
MsgBox (allArray(i, 0))
otherSize = WorksheetFunction.CountA(Worksheets(table).Columns(1))
Do
Worksheets(table).Cells(otherI, 2).Value = Replace(Worksheets(table).Cells(otherI, 2).Value, " * " & allArray(i, 0) & " * ", " * " & allArray(i, 1) & " * ")
otherI = otherI 1
Loop Until otherI > otherSize
otherI = 1
Next i
End Sub
uj5u.com熱心網友回復：
Replace不使用，或者在這種情況下甚至不需要通配符。利用
Replace(Worksheets(table).Cells(otherI, 2).Value, allArray(i, 0), allArray(i, 1))
uj5u.com熱心網友回復：
范圍替換
Range.Replace（微軟檔案）- 僅在一個小資料集上進行測驗（對效率（速度）的反饋表示贊賞）。
- 它將在整個目標范圍內用相關的德語名稱替換每次出現的英文名稱。
- 調整常量部分中的值。
Option Explicit
Sub Germanize()
Const sName As String = "All_Pokemons"
Const sfRow As Long = 2 ' ??? First Row
Const seCol As String = "A" ' ENG
Const sgCol As String = "B" ' GER
Const dName As String = "Sheet2" ' ??? Worksheet Tab Name
Const dfRow As Long = 2 ' ??? First Row
Const deCol As String = "A" ' ENG
Const dgCol As String = "B" ' GER
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source (All)
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim serg As Range: Set serg = RefColumn(sws.Cells(sfRow, seCol)) ' ENG
If serg Is Nothing Then Exit Sub ' no data
Dim seData As Variant: seData = GetRange(serg) ' ENG
Dim sgrg As Range: Set sgrg = serg.EntireRow.Columns(sgCol) ' GER
Dim sgData As Variant: sgData = GetRange(sgrg) ' GER
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim derg As Range: Set derg = RefColumn(dws.Cells(dfRow, deCol)) ' ENG
If derg Is Nothing Then Exit Sub ' no data
Dim dgrg As Range: Set dgrg = derg.EntireRow.Columns(dgCol) ' GER
Application.ScreenUpdating = False
dgrg.Value = derg.Value ' write ENG column to GER column
Dim seValue As Variant
Dim r As Long
' Replace in GER column.
For r = 1 To UBound(seData, 1)
seValue = seData(r, 1)
If Not IsError(seValue) Then
If Len(seValue) > 0 Then
dgrg.Replace seValue, CStr(sgData(r, 1)), xlPart, , False
End If
End If
Next r
Application.ScreenUpdating = True
MsgBox "German pokemon names updated.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefColumn"
On Error GoTo ClearError
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row 1)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/419583.html
標籤：