| |
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
|
|
景山ちゃん
- 06/6/29(木) 19:53 -
