[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『文字の色』（くろ）
いつもお世話になってます。
以前教えてもらって作ったものなのですが
[[20150715132756]]『データを横から縦にした時の転記 No2』（くろ）
[[20150711095654]]『データを横から縦にした時の転記』（くろ）
一覧表シート E列
振伝シート L:M列（結合）
に「〜事業所」「〜支店」があれば文字を赤になるように教えてもらったのですが、
追加で「〜部」をしたのですがどの部分を変更すれば良いのか分かりません。
宜しくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows8 ＞
もう、すっかり忘却のかなたです。そちらの最終形のコードがどうなっているかわかりませんが
With .Range("L1:L12")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*事業所"")"
With .FormatConditions(1).Font
.Color = 255
End With
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*支店"")"
With .FormatConditions(2).Font
.Color = 255
End With
End With
こんなところがありますね。事業所と支店に色を付けているところです。 ここに 部 を、同じような要領で（ただし、.FormatConditions(3).Font) コードを追加すればいかがですか？
（β） 2015/09/04(金) 12:12
↑ あっ！！ このコードは【一回こっきり】内のコードでしたね。 一回こっきりは、通常の運用で使うものではなく、最初に、手作業で、関連ブックの関連シートの数式、書式、テーブル などを設定するかわりに 「サービス」として提供したもので、しかも、そのあとの要件改訂に、すべて対応しているわけではありません。 最終的には、「もう一回こっきりの使用はやめましょう」ということになっていたと記憶。
今、一回こっきりに、このコードを追加して実行したとして、ほかの部分が、現在の仕様にあわずに 障害発生のもとになる可能性があります。
ここは、テーブルのデータ部分（タイトル行を除いた部分）を選択して、そこに対して、この条件付き書式を 手作業で設定されたほうがいいですよ。
（β） 2015/09/04(金) 13:24
（β）さん
早速回答ありがとうございます。
このような式を探したのですが、どこに書いてあるのでしょうか？
以下全式です。
【一覧表シート】
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim st As Long
Dim cnt As Long
If Intersect(Target, ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
Select Case Target.Column
Case 1
'選択された行のみの振伝作成(個別)
st = WorksheetFunction.Match(Target.EntireRow.Range("M1"), Columns("M"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("M"), Target.EntireRow.Range("M1"))
make振伝 st, cnt
ReForm一覧
Worksheets("振伝").Select
Case 2
'選択された日付をもつデータの振伝作成(全て)
ReForm一覧
st = WorksheetFunction.Match(Target.EntireRow.Range("B1"), Columns("B"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("B"), Target)
make振伝 st, cnt
保存
End Select
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim c As Range
Dim i As Long
'入力あった列幅調整のみ
Set r = Intersect(Target, ListObjects(1).DataBodyRange)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each c In r.Rows
'列幅自動調整
c.EntireColumn.AutoFit
c.Offset(-1, 0).EntireRow.Range("H1").Formula = "=IF(一覧リスト[@キー]<>M" & c.Row & ",SUMIF(一覧リスト[キー],一覧リスト[@キー],一覧リスト[金額])-SUMIF(一覧リスト[キー],一覧リスト[@キー],一覧リスト[合計2]),"""")"
Next
'キー列を非表示
Columns("M").Hidden = True
Application.EnableEvents = True
End Sub
【標準モジュール 1】
Option Explicit
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldKey As String
Dim newKey As String
Dim i As Long
Dim j As Long
Dim num As Long
Dim copyFrom As Range
Dim setcnt As Long
Dim crItem1 As String
Dim CrAmt1 As String
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Dim n As Long
Set sh1 = Sheets("一覧表")
Set sh2 = Sheets("振伝")
With sh2.Range("A1", sh2.UsedRange)
If .Rows.Count > 14 Then
.Offset(14).EntireRow.Delete
End If
End With
Set copyFrom = sh2.Rows("1:14")
'各行の取り出し
For i = st To st + cnt - 1
newKey = sh1.Rows(i).Range("M1")
If oldKey <> newKey Then
If pos Is Nothing Then '最初
Set pos = sh2.Range("A1")
Else
Set pos = pos.Offset(14) '次のブロック位置
copyFrom.Copy pos
Application.CutCopyMode = False
End If
'ブロックの初期化
pos.Range("B6:I12").ClearContents
pos.Range("K6:K12").ClearContents
pos.Range("L6:M12").ClearContents
setcnt = 0
num = 1
'貸方項目、ヘッダー項目
dt = sh1.Rows(i).Range("B1").Value
n = WorksheetFunction.CountIf(sh1.ListObjects(1).DataBodyRange.Columns("M"), newKey)
If n > 1 Then
crItem1 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("G1").Resize(n).Value), "")
crItem2 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("I1").Resize(n).Value), "")
CrAmt1 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("H1").Resize(n))
CrAmt2 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("J1").Resize(n))
Else
crItem1 = sh1.Rows(i).Range("G1").Value
crItem2 = sh1.Rows(i).Range("I1").Value
CrAmt1 = sh1.Rows(i).Range("H1").Value
CrAmt2 = sh1.Rows(i).Range("J1").Value
End If
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1
pos.Range("N7").Value = crItem2
pos.Range("S7").Value = CrAmt2
End If
'ヘッダー項目のセット
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
'借方項目のセット
DrRmk = sh1.Rows(i).Range("E1").Value
DrItem = sh1.Rows(i).Range("D1").Value
DrAmt = sh1.Rows(i).Range("F1").Value
If setcnt >= 7 Then '7項目セット済みならブロックを追加
copyFrom.Copy pos.Offset(14)
Application.CutCopyMode = False
Set pos = pos.Offset(14)
num = num + 1
'ブロックの初期化
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
pos.Range("B6:I12").ClearContents
pos.Range("K6:K12").ClearContents
pos.Range("L6:M12").ClearContents
pos.Range("N6").Value = Empty
pos.Range("N7").Value = Empty
pos.Range("S6").Value = Empty
pos.Range("S7").Value = Empty
setcnt = 0
End If
setcnt = setcnt + 1
pos.Range("B6").Offset(setcnt - 1).Value = DrAmt
pos.Range("K6").Offset(setcnt - 1).Value = DrItem
pos.Range("L6").Offset(setcnt - 1).Value = DrRmk
oldKey = newKey
Next
End Sub
Sub 保存()
Dim FileName As String
Dim myDate As Date
Sheets("振伝").Copy
FileName = ThisWorkbook.Path & "\" & Month(myDate) & "月" & ".xlsx"
With ActiveWorkbook
myDate = .Sheets(1).Range("B4")
FileName = ThisWorkbook.Path & "\" & Month(myDate) & "月" & ".xlsx"
.Sheets(1).Name = Month(myDate) & "月"
Application.DisplayAlerts = False '同名ブックあれば無条件上書き
.SaveAs FileName
Application.DisplayAlerts = True
End With
End Sub
Sub ReForm一覧()
Dim r As Range
Dim c As Range
Dim x As Long
With Sheets("一覧表")
'並び替え
.ListObjects("一覧リスト").Sort.SortFields.Clear
.ListObjects("一覧リスト").Sort.SortFields.Add Key:=Range("一覧リスト[日付]"), SortOn:=xlSortOnValues, Order:=xlAscending
.ListObjects("一覧リスト").Sort.SortFields.Add Key:=Range("一覧リスト[振伝順番]"), SortOn:=xlSortOnValues, Order:=xlAscending
.ListObjects("一覧リスト").Sort.SortFields.Add Key:=Range("一覧リスト[事業所]"), SortOn:=xlSortOnValues, Order:=xlAscending
With .ListObjects("一覧リスト").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'A列連番振り直し
.Range("A2").Value = 1
Range("一覧リスト[連番]").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
End Sub
【標準モジュール 2】
Option Explicit
Sub テーブル再設定()
Dim fm As String
Dim tmp As Variant
Application.EnableEvents = False
fm = "=IF(一覧リスト[@キー]<>M3,SUMIF(一覧リスト[キー],一覧リスト[@キー],一覧リスト[金額])-SUMIF(一覧リスト[キー],一覧リスト[@キー],一覧リスト[合計2]),"""")"
With Sheets("一覧表")
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.Cells.Interior.ColorIndex = xlNone
.Cells.Borders.LineStyle = xlNone
With .UsedRange
.Columns("K").Offset(1).Resize(.Rows.Count - 1).Formula = "=IFERROR(VLOOKUP(C2,名前リスト,2,FALSE),"""")"
.Columns("M").Cells(1).Value = "キー"
.Columns("M").Offset(1).Resize(.Rows.Count - 1).Formula = "=TEXT(B2,""yymmdd"")&C2&IF(L2="""","" "",L2)"
'以下は念のため
With .Columns("J").Offset(1).Resize(.Rows.Count - 1)
tmp = .Value
.ClearContents
.Value = tmp
End With
End With
With .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes)
.Name = "一覧リスト"
.TableStyle = "TableStyleLight15"
End With
With .UsedRange
.Columns("H").Offset(1).Resize(.Rows.Count - 1).Value = fm
End With
'キー列を非表示
.Columns("M").Hidden = True
End With
Application.EnableEvents = True
End Sub
【ThisWorkbook】
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
With Sheets("一覧表")
'テーブルの下のＢ列セルを選択
Application.GoTo .Cells(.ListObjects("一覧リスト").ListRows.Count + 2, "B")
End With
Application.EnableEvents = True
End Sub
（くろ） 2015/09/04(金) 13:26
条件書式ですね。やってみます。
ありがとうございます。
（くろ） 2015/09/04(金) 13:28
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.