[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『置換え』（sinmaipapa）
いつも参考にさせていただいております。 置換えですが、うまくいきません。
設定条件式 Cells.Replace What:="A", Replacement:="C" Cells.Replace What:="B", Replacement:="E" Cells.Replace What:="C", Replacement:="K" ･･･20個以上続きます。
元データ A B C
変更したい形 C E K
現状 K E K
おそらくA→Cと置き換えられたものが、またCの条件式に反応してA→C→Kとなってしまっていると思われます。 また、置換えられる値は規則的ではありません。
説明不足があれば指摘してください。
よろしくおねがいします。
お書きのとおりですので、置き換えの順序を変えることで可能なのかもしれません。 C→KをA→Cの前に置換する。 でも、20個以上あるとなると、それらをみないことにはどうにもならないような気もしますし、 書いてあるのはダミーの条件だったりすると、回答が無駄になるような気もしますが。。。 (Hatch)
早速ありがとうございます。 確かにダミーですが、ほとんどそのままです。
順番を入れ替えることで、対応できるところもあるのですが対応しきれないところがあり、 例えば、検索文字列をA&B&Cや、AorBorCみたいな表示をして、1つの条件式にして出来ないかな？と思っています。 なんとなくですが、そうすれば2回検索しないので1回で置換えが済めばこのようなことがおきないのでは？と思っています。
質問の意味が分かりづらいでしょうか？ (sinmaipapa)
置換がセルの内容と完全に一致するものを置き換える場合(LookAt:=xlWhole)であれば「A→!C」「B→!E」「C→!K」に置き換え後、 セルの一部分でも合致したら置き換える置換(LookAt:=xlPart)で「!」を「""」（空文字）に置き換えるといった方法もあるかと。 (独覚)
＞ほとんどそのままです。 の「ほとんど」がくせ者ですよね。
アルファベット一文字で有れば 順番を入れ替えて、最初と最後に成る文字は （と言ってもループするので、どこかの一文字ですが） 最初に違う文字に置き換えておけば良い様に思います。
例えば、A→C,C→K,K→Aの様にループするなら まずKを「★」に変えておいてA→C,C→Kにしたあと ★→Aをする。
(HANA)
かような方法はあります。
ユーザーフォームを一つ作ります。そのフォームは一切さわらなくてもいいです。
標準モジュールに
Sub 検索()
UserForm1.Show
End Sub
をコピペ
後フォームモジュールに下のコードを貼り付けます。
検索を実行し、検索文字を _ で区切ります。A_B_C といった塩梅に。
置き換えをクリックし、今度は置き換え文字を書き込みます。これも _ で区切って
書き込みます。
後は必要項目をクリックすれば置き換わります。
（弥太郎）
'-------------------------
Option Explicit
Private flg As Boolean
Private txt As Boolean
Private Lbl As MSForms.Label
Private c_1 As Boolean, c_2 As Boolean, c_3 As Boolean
Private WithEvents 全て置き換え As MSForms.CommandButton
Private WithEvents txtbox As MSForms.TextBox
Private WithEvents cmb1 As MSForms.ComboBox
Private WithEvents テキスト As MSForms.TextBox
Private WithEvents check_1 As MSForms.CheckBox
Private WithEvents check_2 As MSForms.CheckBox
Private WithEvents check_3 As MSForms.CheckBox
Private WithEvents cmb As MSForms.ComboBox
Private WithEvents 検索 As MSForms.CommandButton
Private WithEvents 閉じる As MSForms.CommandButton
Private WithEvents 置き換え As MSForms.CommandButton
Private Sub check_1_Click()
c_1 = IIf(check_1, 1, 0)
txt = True
End Sub
Private Sub check_2_Click()
c_2 = IIf(check_2, 1, 0)
txt = True
End Sub
Private Sub check_3_Click()
c_3 = IIf(check_3, 1, 0)
txt = True
End Sub
Private Sub cmb_Click()
txt = True
End Sub
Private Sub cmb1_Click()
txt = True
End Sub
Private Sub txtbox_Change()
flg = True
End Sub
Private Sub テキスト_Change()
txt = True
End Sub
Private Sub 検索_Click()
Dim txt1 As String, c As Range, txt2 As String, rng As Range, data, x
Dim u As Integer, i As Integer, fnd_type, y(), tbl
Application.ScreenUpdating = False
txt1 = Replace(テキスト.Text, "＿", "_")
txt2 = cmb.Value
data = Split(txt1, "_", -1)
Static flag As Boolean
Static b As Integer
Static m() As Variant
If txt Then flag = False: txt = False
With CreateObject("vbscript.regexp")
.Pattern = "(\D+)(\d+)"
If UBound(data) <> 0 And Not flag Then
fnd_type = IIf(cmb1 = "値", xlCellTypeConstants, xlCellTypeFormulas)
Cells.SpecialCells(fnd_type).Cells(1, 1).Activate
ReDim x(1 To Rows.Count, 1 To 2)
For i = 0 To UBound(data)
For Each rng In Cells.SpecialCells(fnd_type)
On Error Resume Next
Set c = rng.Find(What:=data(i), LookIn:=IIf(cmb1 = "値", xlValues, xlFormulas), _
LookAt:=IIf(c_3, xlWhole, xlPart), MatchCase:=IIf(c_1, True, False), _
MatchByte:=IIf(c_2, True, False))
If Not c Is Nothing Then
ReDim Preserve y(u)
If IsError(Application.Match(c.Address(0, 0), y, 0)) Then
y(u) = c.Address(0, 0)
u = u + 1
x(u, 1) = .Replace(c.Address(0, 0), "$1")
x(u, 2) = .Replace(c.Address(0, 0), "$2")
End If
End If
Next rng
Next i
If u = 0 Then MsgBox "そのデータはみあたりまへん", vbExclamation: Exit Sub
Sheets.Add.Name = "dmy"
With Sheets("dmy")
.Range("a1").Resize(u, 2) = x
.Range("a1").Resize(u, 2).Sort _
key1:=IIf(txt2 = "行", .Range("b1"), .Range("a1")), Order1:=xlAscending, key2:= _
IIf(txt2 = "行", .Range("a1"), .Range("b1")), Order2:=xlAscending
tbl = .Range("a1").Resize(u, 2)
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
For i = 1 To u
ReDim Preserve m(i - 1)
m(i - 1) = tbl(i, 1) & tbl(i, 2)
Next
flag = True
b = 0
Range(m(b)).Activate
ElseIf flag Then
b = b + 1
If UBound(m) + 1 = b Then b = 0
On Error Resume Next
Range(m(b)).Activate
If IsError(Range(m(b)).Activate) Then
MsgBox "予期せぬエラーが発生しました。もう一度やり直してくらはい。", vbExclamation
Unload Me
Exit Sub
End If
Else
On Error Resume Next
If cmb1 = "数式" Then
ReDim x(1 To Rows.Count, 1 To 2)
For Each rng In Cells.SpecialCells(xlCellTypeFormulas)
On Error Resume Next
Set c = rng.Find(What:=テキスト.Text, LookIn:=xlFormulas, _
LookAt:=IIf(c_3, xlWhole, xlPart), MatchCase:=IIf(c_1, True, False), _
MatchByte:=IIf(c_2, True, False))
If Not c Is Nothing Then
ReDim Preserve y(u)
If IsError(Application.Match(c.Address(0, 0), y, 0)) Then
y(u) = c.Address(0, 0)
u = u + 1
x(u, 1) = .Replace(c.Address(0, 0), "$1")
x(u, 2) = .Replace(c.Address(0, 0), "$2")
End If
End If
Next rng
If u = 0 Then MsgBox "そのデータはみあたりまへん", vbExclamation: Exit Sub
Sheets.Add.Name = "dmy"
With Sheets("dmy")
.Range("a1").Resize(u, 2) = x
.Range("a1").Resize(u, 2).Sort _
key1:=IIf(txt2 = "行", .Range("b1"), .Range("a1")), Order1:=xlAscending, key2:= _
IIf(txt2 = "行", .Range("a1"), .Range("b1")), Order2:=xlAscending
tbl = .Range("a1").Resize(u, 2)
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
For i = 1 To u
ReDim Preserve m(i - 1)
m(i - 1) = tbl(i, 1) & tbl(i, 2)
Next
flag = True
b = 0
Range(m(b)).Activate
Else
Cells.Find(What:=txt1, After:=ActiveCell, LookIn:=IIf(cmb1 = "値", xlValues, _
xlFormulas), LookAt:=IIf(c_3, xlWhole, xlPart), SearchOrder:=IIf(txt2 = _
"行", xlByRows, xlByColumns), SearchDirection:=xlNext, MatchCase:= _
IIf(c_1, True, False), MatchByte:=IIf(c_2, True, False)).Activate
End If
End If
If Err.Number = 91 Then
MsgBox "それはありまへ～ん", vbExclamation
Err.Clear
End If
End With
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Private Sub 全て置き換え_Click()
Dim txt_data As String, i As Integer, u As Integer, rng As Range, data_1
Dim c As Range, actvdata As String, data As String, n As Integer, swch_data, f_data
Dim data_2
txt_data = Replace(テキスト.Text, "＿", "_")
If Not txt_data Like "*_*" Then
On Error Resume Next
Cells.Replace What:=テキスト.Text, Replacement:=txtbox.Text, LookAt:= _
IIf(c_3, xlWhole, xlPart), SearchOrder:=IIf(cmb = "行", xlByRows, xlByColumns), _
MatchCase:=IIf(c_1, True, False), MatchByte:=IIf(c_2, True, False)
If Err.Number = 1004 Then
MsgBox "入力された式は成立しません！", vbExclamation
Err.Clear
On Error GoTo 0
Exit Sub
End If
Else
With CreateObject("vbscript.regexp")
If Replace(txtbox.Text, "＿", "_") Like "*_*" Then
data_1 = Split(txt_data, "_", -1)
data_2 = Split(Replace(txtbox.Text, "＿", "_"), "_", -1)
If UBound(data_1) <> UBound(data_2) Then
MsgBox "置き換えの数がちゃいます！", vbExclamation
txtbox.Text = ""
txtbox.SetFocus
Else
For Each rng In Cells.SpecialCells(IIf(cmb1 = "値", xlCellTypeConstants, xlCellTypeFormulas))
swch_data = IIf(cmb1 = "値", rng.Value, rng.Formula)
For i = 0 To UBound(data_1)
Set c = rng.Find(What:=data_1(i), LookIn:=IIf(cmb1 = "値", xlValues, xlFormulas), _
LookAt:=IIf(c_3, xlWhole, xlPart), MatchCase:=IIf(c_1, True, False), _
MatchByte:=IIf(c_2, True, False))
If Not c Is Nothing Then
If swch_data Like "=*" Then
data = StrConv(StrConv(data_1(i), vbNarrow), vbUpperCase)
actvdata = swch_data
Else
If c_1 + c_2 + c_3 = 0 Then
data = StrConv(StrConv(data_1(i), vbWide), vbUpperCase)
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
End If
If c_1 Then
data = StrConv(data_1(i), vbWide)
actvdata = StrConv(swch_data, vbWide)
End If
If c_2 Then
data = StrConv(data_1(i), vbUpperCase)
actvdata = StrConv(swch_data, vbUpperCase)
End If
If c_1 And c_2 Then
data = data_1(i)
actvdata = swch_data
End If
If c_3 Then
If c_1 + c_2 = 0 Then
data = StrConv(StrConv(data_1(i), vbWide), vbUpperCase)
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
End If
End If
End If
.Pattern = data
.Global = True
If .test(actvdata) Then
n = WorksheetFunction.Find(data, actvdata, 1)
For u = 1 To .Execute(actvdata).Count
On Error Resume Next
f_data = IIf(cmb1 = "値", rng.Value, rng.Formula)
rng = WorksheetFunction.Replace(f_data, WorksheetFunction _
.Find(data, actvdata, n), Len(data), data_2(i))
If swch_data Like "=*" Then
actvdata = rng.Formula
Else
actvdata = IIf(c_1 + c_2 + c_3 = 0, StrConv(StrConv(rng, vbWide), _
vbUpperCase), IIf(c_1 And c_2, rng, IIf(c_1, StrConv(rng, _
vbWide), IIf(c_2, StrConv(rng, vbUpperCase), rng))))
End If
n = WorksheetFunction.Find(data, actvdata, 1 + Len(data_2(i)) - _
Len(data) + 1) + Len(data_2(i)) - Len(data)
Next u
End If
End If
Next i
Next rng
End If
Else
For Each rng In Cells.SpecialCells(IIf(cmb1 = "値", xlCellTypeConstants, xlCellTypeFormulas))
For i = 0 To UBound(data_1)
Set c = rng.Find(What:=data_1(i), LookIn:=IIf(cmb1 = "値", xlValues, xlFormulas), _
LookAt:=IIf(c_3, xlWhole, xlPart), MatchCase:=IIf(c_1, True, False), _
MatchByte:=IIf(c_2, True, False))
If Not c Is Nothing Then
If swch_data Like "=*" Then
data = StrConv(StrConv(data_1(i), vbNarrow), vbUpperCase)
actvdata = swch_data
Else
If c_1 + c_2 + c_3 = 0 Then
data = StrConv(StrConv(data_1(i), vbWide), vbUpperCase)
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
End If
If c_1 Then
data = StrConv(data_1(i), vbWide)
actvdata = StrConv(swch_data, vbWide)
End If
If c_2 Then
data = StrConv(data_1(i), vbUpperCase)
actvdata = StrConv(swch_data, vbUpperCase)
End If
If c_1 And c_2 Then
data = data_1(i)
actvdata = swch_data
End If
If c_3 Then
If c_1 + c_2 = 0 Then
data = StrConv(StrConv(data_1(i), vbWide), vbUpperCase)
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
End If
End If
End If
.Pattern = data
.Global = True
If .test(actvdata) Then
n = WorksheetFunction.Find(data, actvdata, 1)
For u = 1 To .Execute(actvdata).Count
On Error Resume Next
f_data = IIf(cmb1 = "値", rng.Value, rng.Formula)
rng = WorksheetFunction.Replace(f_data, WorksheetFunction _
.Find(data, actvdata, n), Len(data), txtbox.Text)
If swch_data Like "=*" Then
actvdata = rng.Formula
Else
actvdata = IIf(c_1 + c_2 + c_3 = 0, StrConv(StrConv(rng, vbWide), _
vbUpperCase), IIf(c_1 And c_2, rng, IIf(c_1, StrConv(rng, _
vbWide), IIf(c_2, StrConv(rng, vbUpperCase), rng))))
End If
n = WorksheetFunction.Find(data, actvdata, 1 + Len(txtbox.Text) - _
Len(data) + 1) + Len(txtbox.Text) - Len(data)
Next u
End If
End If
Next i
Next rng
End If
End With
End If
txt = True
End Sub
Private Sub 置き換え_Click()
Dim i As Integer, txt_data As String, actvdata As String, data_1, data_2
Dim data As String, n As Integer, u As Integer, swch_data
txt_data = Replace(テキスト.Text, "＿", "_")
If flg Then
If txt_data Like "*_*" Then
With CreateObject("vbscript.regexp")
swch_data = IIf(cmb1 = "値", ActiveCell.Value, ActiveCell.Formula)
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
data_1 = Split(txt_data, "_", -1)
If Replace(txtbox.Text, "＿", "_") Like "*_*" Then
data_2 = Split(Replace(txtbox.Text, "＿", "_"), "_", -1)
If UBound(data_1) <> UBound(data_2) Then
MsgBox "置き換えの数がちゃいます！", vbExclamation
txtbox.Text = ""
txtbox.SetFocus
Else
For i = 0 To UBound(data_1)
data = StrConv(StrConv(data_1(i), vbWide), vbUpperCase)
.Pattern = data
.Global = True
If .test(actvdata) Then
n = 1
For u = 1 To .Execute(actvdata).Count
On Error Resume Next
ActiveCell = WorksheetFunction.Replace(swch_data, WorksheetFunction _
.Find(data, actvdata, n), Len(data), data_2(i))
If Err.Number = 1004 Then
MsgBox "その式は成立しまへん!", vbExclamation
Err.Clear
On Error GoTo 0
Exit Sub
End If
n = WorksheetFunction.Find(data, actvdata, n) + Len(data_2(i)) _
- Len(data) + 1
swch_data = IIf(cmb1 = "値", ActiveCell.Value, ActiveCell.Formula)
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
Next u
End If
Next i
End If
Else
For i = 0 To UBound(data_1)
data = StrConv(StrConv(data_1(i), vbWide), vbUpperCase)
.Pattern = data
.Global = True
If .test(actvdata) Then
n = 1
For u = 1 To .Execute(actvdata).Count
ActiveCell = WorksheetFunction.Replace(swch_data, WorksheetFunction _
.Find(data, actvdata, n), Len(data), txtbox.Text)
n = WorksheetFunction.Find(data, actvdata, n) + Len(txtbox.Text) - Len(data) + 1
actvdata = StrConv(StrConv(swch_data, vbWide), vbUpperCase)
Next u
End If
Next i
End If
End With
Else
On Error Resume Next
ActiveCell.Replace What:=テキスト.Text, Replacement:=txtbox.Text, _
LookAt:=IIf(c_3, xlWhole, xlPart), SearchOrder:=IIf(cmb = "行", _
xlByRows, xlByColumns), MatchCase:=IIf(c_1, True, False), _
MatchByte:=IIf(c_2, True, False)
ActiveCell.Select
End If
Else
txtbox.Visible = True
Lbl.Visible = True
txtbox.SetFocus
flg = True
全て置き換え.Visible = True
End If
On Error GoTo 0
End Sub
Private Sub 閉じる_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim obj As Object
With Me
.Width = 330
.Height = 140
.Caption = "スペシャル検索"
End With
With Controls.Add("forms.label.1", , True)
.Top = 8
.Left = 15
.Height = 12
.Width = 150
.Caption = "検索文字列（ _ で区切ると複数可能）"
End With
Set テキスト = Controls.Add("forms.textbox.1", , True)
With テキスト
.Name = "テキスト"
.Top = 21
.Left = 12
.Height = 15
.TabIndex = 0
.Width = 220
.ControlTipText = "複数検索のばやいは 「_」 で区切って入力"
End With
Set txtbox = Controls.Add("forms.textbox.1", , True)
With txtbox
.Name = "txtbox"
.Top = 52
.Left = 12
.Height = 15
.Width = 220
.Visible = False
End With
Set Lbl = Controls.Add("Forms.Label.1", , True)
With Lbl
.Top = 40
.Left = 15
.Height = 12
.Width = 150
.Caption = "置き換え文字列"
.Visible = False
End With
With Controls.Add("forms.label.1", , True)
.Top = 75
.Height = 12
.Left = 12
.Width = 42
.Caption = "検索方向"
End With
Set cmb = Controls.Add("forms.combobox.1", , True)
With cmb
.Top = 70
.Left = 66
.Height = 18
.Width = 54
.AddItem "行"
.AddItem "列"
.Text = .List(0)
End With
Set check_1 = Controls.Add("forms.checkbox.1", , True)
With check_1
.Height = 13
.Left = 132
.Top = 68
.Width = 102
.Caption = "大文字小文字を区別する"
End With
Set check_2 = Controls.Add("forms.checkbox.1", , True)
With check_2
.Height = 13
.Left = 132
.Top = 82
.Width = 102
.Caption = "全角半角を区別する"
End With
Set check_3 = Controls.Add("forms.checkbox.1", , True)
With check_3
.Height = 13
.Left = 132
.Top = 98
.Width = 102
.Caption = "完全一致の検索"
End With
Set 検索 = Controls.Add("forms.commandbutton.1", , True)
With 検索
.Height = 17
.Left = 260
.Top = 13
.Width = 50
.Caption = "検 索"
.TabIndex = 1
End With
Set 閉じる = Controls.Add("forms.commandbutton.1", , True)
With 閉じる
.Height = 17
.Left = 260
.Top = 36
.Width = 50
.Caption = "閉じる"
End With
Set 置き換え = Controls.Add("forms.commandbutton.1", , True)
With 置き換え
.Height = 17
.Left = 260
.Top = 60
.Width = 50
.Caption = "置き換え"
End With
Set 全て置き換え = Controls.Add("forms.commandbutton.1", , True)
With 全て置き換え
.Height = 17
.Left = 260
.Top = 84
.Width = 50
.Caption = "全て置き換え"
.Visible = False
End With
Set cmb1 = Controls.Add("forms.combobox.1", , True)
With cmb1
.Top = 90
.Left = 66
.Height = 18
.Width = 54
.AddItem "値"
.AddItem "数式"
.Text = .List(0)
End With
With Controls.Add("forms.label.1", , True)
.Top = 95
.Left = 12
.Height = 12
.Width = 42
.Caption = "対象"
End With
End Sub
皆様ありがとうございます。 弥太郎さんのはすごいですね。 勉強不足の私には、半分ぐらいしか理解が出来ませんでした。
HANAさんの言うとおり確かに、だいたい･･･がくせものですね。
実際の物の1部です。
C→CD CIF→CL R→RG RC→RCのまま
と、言ったようにしたいのですが、今は C→CD CIF→CDIF R→RG RC→RGCD
となっていました。
独覚さんのLookAt:=xlWholeで対応できました。 完全一致の変換。新しい知識が増えました。
ありがとうございます。 (shinmaipapa)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.