以前、

http://q.hatena.ne.jp/1256673835

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

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

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

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

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2010/04/03 14:49:31
  • 終了:2010/04/05 12:28:37

ベストアンサー

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692010/04/05 11:03:49

ポイント100pt

★愛媛産みかん【バ】£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
id:naranara19

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

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

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

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

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

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

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

2010/04/05 12:28:06

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692010/04/03 23:56:46

ポイント100pt

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

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

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

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

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


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
id:naranara19

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


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


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

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


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

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


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

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

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

しかし、

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

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

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

【バ】■★(判定可)

【バ】]■★(判定可)

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

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



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

2010/04/04 19:10:55
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692010/04/05 11:03:49ここでベストアンサー

ポイント100pt

★愛媛産みかん【バ】£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
id:naranara19

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

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

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

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

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

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

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

2010/04/05 12:28:06

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません