恐れ入りますが、マクロの作成をお願いいたします。
「★」というシート名にリストがありまして、商品名がA2~A500くらいまで並んでいます。
上位の100行くらいが連続で黒以外の色になっています。
その上位から黒以外の字になっている箇所の文末の文字列を読み取ってコピーし、同じブック内の「場所」というシートの中の一致する場所の横にペーストしてほしいのです。

A2以下の値は40文字程度の文字列です。

文末のパターンが不一致のため、ややこしい部分があります。文字列の文末のパターンは以下の通りです。

【バ】■rbc★
【バ】■r★
【バ】■
【バ】]■r★
【バ】]■
■rbc★
■r★


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

非常にわかりづらいので、画像でアップしました。下記URLの「1~3」がマクロの流れとなります。ぜひご確認くださいませ。
http://photos.yahoo.co.jp/bc/hatenasenyou19/
(はてな20091028)

回答の条件
  • 1人3回まで
  • 登録:2009/10/28 05:03:56
  • 終了:2009/10/29 00:47:43

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/10/28 14:40:15

ポイント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
                
                For Each rng In Worksheets("場所").UsedRange
                    If 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, Len(rng.Value)) = "$" Then
                                    kw = "$"
                                End If
                            Else
                                If StrConv(Right(s1, Len(rng.Value)), vbWide) = _
                                    StrConv(CStr(rng.Value), vbWide) And Len(kw) < Len(rng.Value) Then
                                    kw = rng.Value
                                End If
                            End If
                        End If
                    End If
                Next
                  
                '【バ】が含まれるか
                p = InStr(1, s, "【バ】")
                If p > 0 Then
                    If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 4), 3), vbWide) = "rbc" Then
                        kw = Mid(s, p + 3, Len(s) - p - 6)
                    Else
                        If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 2), 1), vbWide) = "r" Then
                            kw = Mid(s, p + 3, Len(s) - p - 4)
                        Else
                            kw = Right(s, Len(s) - p - 2)
                        End If
                    End If
                End If
                
                '【バ】]が含まれるか
                p = InStr(1, s, "【バ】]")
                If p > 0 Then
                    If IsNumeric(Right(s, 1)) And StrConv(Left(Right(s, 2), 1), vbWide) = "r" Then
                        kw = Mid(s, p + 4, Len(s) - p - 5)
                    Else
                        kw = Right(s, Len(s) - p - 3)
                    End If
                End If
                
                'データ転記
                kw = Replace(kw, "£", "")
                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

いつもいつもありがとうございます。びっくりするくらい完璧に動きました。大変な仕様なのに、感謝いたします。本当にありがとうございました!

2009/10/29 00:47:26
  • id:naranara19
    上記で書ききれないので、補足いたします。


    「場所」シートの内容
    ■の部分に入る文字列(位置関係など、変わることがあります)(ただし、■の文字はA列、C列、E列、G列、I列、K列、L列、N列までとします。列ないに文字がないケースもあり)
     
    G A4 2 B1 r0
    s3 W R B2 r1
    C2 X A B3 r
    m X2 D B4
    e V J B5
    f V2 S B6
    M B7
    Y B8
    B9
    F
    $ ←これのみ全角 H
    $8 ←半角+半角 G

    【ペーストの指定】
    ■部分と、ペースト先のシートの■が一致したときに、その横に40文字程度の文面すべてそのままペーストします。ペーストされた先は縮小されてすべて表示されます。
    一致する文面が多いときには、挿入する形で増やしていってほしいです。
    ★シートと、場所シートの値を比べるとき、小文字と大文字は区別します。半角と全角は区別しないがうれしいのですが、難しいようであれば、半角基本でお願いします。その場合、$のみ、半角全角を区別していただきたいです。

    Gのように同じ名前があるケースがありますが、その場合は「場所」シートの該当箇所両方に入力(多いときには挿入)されます。
    うまく読み取れない場合、エラーとして、「★」シートの該当箇所のセル内を黄色で色塗っていただけるとありがたいです。

    お手数をおかけしますが、よろしくお願いいたします。

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

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

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

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