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


恐れ入りますが、マクロの作成をお願いいたします。
「★」というシート名にリストがありまして、商品名が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)

●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
✍キーワード:RBC にわか はてな コピー パターン
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

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
 
 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
◎質問者からの返答

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

関連質問


●質問をもっと探す●



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