Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7343 / 13645 ツリー ←次へ | 前へ→

【39720】塗り潰しを別シートに反映させるには? 景山ちゃん 06/6/29(木) 19:53 質問[未読]

【39720】塗り潰しを別シートに反映させるには?
質問  景山ちゃん WEB  - 06/6/29(木) 19:53 -

引用なし
パスワード
   http://www.geocities.jp/kageyamaworks/Book001.xls

こんにちは。URLを参照して下さい。

"実行前"シートに野菜&果物の一覧表があります。
"作成"シートにあるボタンをクリックすると、
一覧表が"実行後"シートの様な書式に変更されるマクロを作成しようと考えています。

●条件
1."作成"シートより左側にあるシートのみに反映される。
 (右側のsheet1や2には反映されない)
2."作成"シートのB列にてあらかじめ登録している文字の塗り潰し色を
 そのまま"実行前"シートの一覧表の文字に反映させる。
 ※反映されたのが"実行後"シート
3.ただし、("実行後"シート参照)
 A4〜A6、B4〜B6、・・・O4〜O6(1段目)
 A20〜A22、B20〜B22、・・・O20〜O22(2段目)
 A36〜A38、B36〜B38、・・・O36〜O38(3段目)
 A52〜A54、B52〜B54、・・・O52〜O54(4段目)
 のそれぞれの3つのセルはそのまま4、20、36、52行の塗り潰し色を反映させる。
4.A4〜A6、B4〜B6、・・・O4〜O6(1段目)
 A20〜A22、B20〜B22、・・・O20〜O22(2段目)
 A36〜A38、B36〜B38、・・・O36〜O38(3段目)
 A52〜A54、B52〜B54、・・・O52〜O54(4段目)
 のセルの塗り潰しを判別し、隣り合ったセルの色が異なれば
 縦16セル分に対して、境界線(罫線)を作成。

条件が多いですがよければチカラを貸して下さい。
宜しくお願い致します。

程遠いですが一応試行錯誤で作ったコードです。

●塗り潰し
 ※条件3.に対応してませんが。。。

Sub 塗り潰し()
Dim tb As Variant
Dim r As Variant
Dim i As Variant
Sheets("Sheet2").Select
With Sheets("Sheet2")
 Set tb = .Range("b1", .Range("b50000").End(xlUp))
End With
Sheets("sheet1").Select
With Sheets("Sheet1")
 For Each r In .Range("a1", .Range("O100").End(xlUp))
  With r
   For i = 1 To UBound(tb.Value)
    If .Value = tb(i, 1) Then
     .Interior.ColorIndex = tb(i, 1).Interior.ColorIndex
     Exit For
    End If
   Next
  End With
 Next
End With
End Sub

●罫線作成
(イベントで行った為失敗。しかもひとつのセルのみでしか罫線が引けてません。)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
  Dim mRng As Range
  Dim mR  As Range
  If Sh.Index = Worksheets.Count Then Exit Sub
  Set mRng = Intersect(Target, Sh.Range("A4:N4,A20:N20,A36:N36"))
  If mRng Is Nothing Then Exit Sub
  For Each mR In Sh.Range("A4:N4,A20:N20,A36:N36") 'mRng
    If Left(mR.Value, 5) <> Left(mR(1, 2), 5) And _
      Not IsEmpty(mR) Then
      With mR.Borders(xlRight)
        .LineStyle = xlContinuous
        .Weight = 4
        .ColorIndex = 3
      End With
    Else
      mR.Borders(xlEdgeRight).LineStyle = xlNone
    End If
  Next
End Sub

7343 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free