人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

以前、
http://q.hatena.ne.jp/1256673835

にて質問させていただいたものです。
できれば、SALINGERさん、よろしくお願いいたします。

仕様を少し変えまして、以前のものを少し変えて、下記のような場合に動くようにしていただきたいのです。

【バ】■★
【バ】■
【バ】]■★
【バ】]■

■部分は、半角の英数字2文字、もしくは1文字分。
■の前に「?」(ポンド)マークが入っていることがまれにあります。
★の部分は半角数値の0?9までが1文字だけ入ります。

お手数をおかけしますが、お気づきでしたらご協力をよろしくお願いいたします。

●質問者: naranara19
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:ポンド マーク 仕様 数字 気づき
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●100ポイント

回答が遅れて申し訳ありません。

前回からしばらく経つのでどのようなコードだったのかを思い出すのに苦労しました。

前回のコードを改めて見ると、どうやら間違いがあるようです。

間違いを修正するとともに、今回の変更に対応させました。

特定の文字列でうまくいかないときは、修正しますのでお知らせください。


Sub Macro()
 Dim r As Long
 Dim lastRow As Long
 Dim kw As String
 Dim s As String
 Dim s1 As String
 Dim p As Integer
 Dim rng As Range
 Dim rng2 As Range
 
 With Worksheets("★")
 lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
 
 For r = 2 To lastRow
 If .Cells(r, 1).Font.ColorIndex <> 1 And .Cells(r, 1).Font.ColorIndex <> -4105 Then
 
  'キーの判別
 kw = ""
 s = .Cells(r, 1).Value
 
  'r数字とrsc数字を削除
 s1 = s
 If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 4), 3), vbWide) = "rbc" Then
 s1 = Left(s, Len(s) - 4)
 End If
 If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 2), 1), vbWide) = "r" Then
 s1 = Left(s, Len(s) - 2)
 End If
 
  '1文字のキーがあるか
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 1 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If rng.Value <> "" Then
 If rng.Value = "$" Then
 If Right(s1, 1) = "$" Then
 kw = "$"
 End If
 Else
 If StrConv(Right(s1, 1), vbWide) = _
 StrConv(CStr(rng.Value), vbWide) And Len(s1) > 1 Then
 kw = rng.Value
 End If
 End If
 End If
 End If
 Next
 
  '2文字のキーがあるか
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 2 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If rng.Value <> "" Then
 If StrConv(Right(s1, 2), vbWide) = _
 StrConv(CStr(rng.Value), vbWide) And Len(s1) > 2 Then
 kw = rng.Value
 End If
 End If
 End If
 Next
 
  '【バ】■★のケース
 If (kw = "" Or (IsNumeric(kw) And Len(kw) = 1)) And IsNumeric(Right(s, 1)) Then
 If InStr(1, s, "【バ】") > 0 And s = s1 Then
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 2 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If rng.Value <> "" Then
 s1 = Left(s, Len(s) - 1)
 If StrConv(Right(s1, Len(rng.Value)), vbWide) = _
 StrConv(CStr(rng.Value), vbWide) And Len(s1) > Len(rng.Value) Then
 kw = rng.Value
 End If
 End If
 End If
 Next
 End If
 End If
 
  'データ転記
 If kw <> "" Then
 Set rng2 = Worksheets("場所").Cells.Find(what:=kw, LookAt:=xlWhole, MatchCase:=True, MatchByte:=False)
 If Not rng2 Is Nothing Then
 If rng2.Offset(0, 1).Value = "" Then
 .Cells(r, 1).Copy rng2.Offset(0, 1)
 Else
 rng2.Offset(1, 1).Insert shift:=xlDown
 rng2.Offset(1, 0).Insert shift:=xlDown
 .Cells(r, 1).Copy rng2.Offset(1, 1)
 End If
 .Cells(r, 1).Interior.ColorIndex = xlNone
 End If
 Else
 .Cells(r, 1).Interior.ColorIndex = 36
 End If
 
  'キー確認用
 ' .Cells(r, 2).Value = kw
 End If
 Next
 End With
End Sub
◎質問者からの返答

SALINGERさん、いつも素早いご回答心より感謝いたします。


早速試してみたのですが、うまくいっておりません。


★愛媛産みかん【バ】?155

というタイトルのものは15というところの管理番号に飛んでほしいのですが、5の場所に貼り付けられています。


★南米産バナナ【バ】]m5

というものはmのところに張り付いてほしいのですが、5についております。


他も同様でして、どうやら最後の数字を読み取っているようです。

そうではなく、■に入っている内容をよみとって貼り付けていただきたいのです。

その■は2文字のケースがあります。ですので、最後の数字をのけたあとに判定していただければありがたいです。

しかし、

質問をみていて、私の設定がいけないようでした。申し訳ありません。

必ず★の数字が半角で1文字入るとしていただけますでしょうか?それならばやりやすいのではないかと思います。

【バ】★(判定できず薄い黄色が塗られる)

【バ】■★(判定可)

【バ】]■★(判定可)

【バ】]?■★(判定可)

【バ】(判定できず薄い黄色が塗られる)



お手数ですが、もう少しお付き合いくださいませ。


2 ● SALINGER
●100ポイント ベストアンサー

★愛媛産みかん【バ】?155

15よりも5が後に出てくることにより5がマッチしていました。


★南米産バナナ【バ】]m5

がマッチしなかったケースは■を2文字に限定していたためにおこったコードミスでした。


以上のことを考慮し、判定順序を変更して大幅に変更してみました。

Sub Macro()
 Dim r As Long
 Dim lastRow As Long
 Dim kw As String
 Dim s As String
 Dim s1 As String
 Dim s2 As String
 Dim rng As Range
 Dim rng2 As Range
 Dim i As Integer
 
 With Worksheets("★")
 lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
 
 For r = 2 To lastRow
 If .Cells(r, 1).Font.ColorIndex <> 1 And .Cells(r, 1).Font.ColorIndex <> -4105 Then
 
  'キーの判別
 kw = ""
 s = .Cells(r, 1).Value
 
  'r数字とrsc数字を削除
 s1 = s
 If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 4), 3), vbWide) = "rbc" Then
 s1 = Left(s, Len(s) - 4)
 End If
 If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 2), 1), vbWide) = "r" Then
 s1 = Left(s, Len(s) - 2)
 End If
 
  '【バ】が含まれるかどうか
 i = InStrRev(s1, "【バ】")
 If i > 0 Then
 s2 = Replace(Replace(Right(s1, Len(s1) - i - 2), "]", ""), "?", "")
 Select Case Len(s2)
 Case 1
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 1 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If rng.Value = "$" Then
 If s2 = "$" Then
 kw = "$"
 End If
 Else
 If StrConv(s2, vbWide) = StrConv(CStr(rng.Value), vbWide) Then
 kw = rng.Value
 End If
 End If
 End If
 Next
 Case 2
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 2 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If StrConv(s2, vbWide) = StrConv(CStr(rng.Value), vbWide) Then
 kw = rng.Value
 End If
 End If
 Next
 End Select
 If kw = "" And (Len(s2) = 2 Or Len(s2) = 3) And IsNumeric(Right(s2, 1)) And s = s1 Then
 s2 = Left(s2, Len(s2) - 1)
 Select Case Len(s2)
 Case 1
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 1 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If rng.Value = "$" Then
 If s2 = "$" Then
 kw = "$"
 End If
 Else
 If StrConv(s2, vbWide) = StrConv(CStr(rng.Value), vbWide) Then
 kw = rng.Value
 End If
 End If
 End If
 Next
 Case 2
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 2 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If StrConv(s2, vbWide) = StrConv(CStr(rng.Value), vbWide) Then
 kw = rng.Value
 End If
 End If
 Next
 End Select
 End If
 Else
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 1 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If rng.Value = "$" Then
 If Right(s1, 1) = "$" Then
 kw = "$"
 End If
 Else
 If StrConv(Right(s1, 1), vbWide) = StrConv(CStr(rng.Value), vbWide) And Len(s1) > 1 Then
 kw = rng.Value
 End If
 End If
 End If
 Next
 
 For Each rng In Worksheets("場所").UsedRange
 If Len(rng.Value) = 2 And (rng.Column = 1 Or rng.Column = 3 Or rng.Column = 5 Or rng.Column = 7 Or _
 rng.Column = 9 Or rng.Column = 11 Or rng.Column = 13 Or rng.Column = 15) Then
 If StrConv(Right(s1, 2), vbWide) = StrConv(CStr(rng.Value), vbWide) And Len(s1) > 2 Then
 kw = rng.Value
 End If
 End If
 Next
 End If
 
  'データ転記
 If kw <> "" Then
 Set rng2 = Worksheets("場所").Cells.Find(what:=kw, LookAt:=xlWhole, MatchCase:=True, MatchByte:=False)
 If Not rng2 Is Nothing Then
 If rng2.Offset(0, 1).Value = "" Then
 .Cells(r, 1).Copy rng2.Offset(0, 1)
 Else
 rng2.Offset(1, 1).Insert shift:=xlDown
 rng2.Offset(1, 0).Insert shift:=xlDown
 .Cells(r, 1).Copy rng2.Offset(1, 1)
 End If
 .Cells(r, 1).Interior.ColorIndex = xlNone
 End If
 Else
 .Cells(r, 1).Interior.ColorIndex = 36
 End If
 
  'キー確認用
' .Cells(r, 2).Value = kw
 End If
 Next
 End With
End Sub
◎質問者からの返答

完璧に動作いたしました!!

再びコードを思い出していただき、かつ大幅のコード変更など、

大変お手数をおかけしました。

深く感謝しております。SALINGERさんのおかげで、

ミスが少なく仕事できています。

多くのお客様に感謝してもらっておりまして、これもSALINGERさんをはじめとするご回答者皆様のおかげです。

本当にありがとうございました。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ