Embedded Files
Hello
20180418MainPanel3n-20190709
20180418MainPanel3n-20190709
Sheet1
Sheet1
Macro起動用ボタン
Private Sub 色の塗りなおし3_Click() ' Texture用Mapの作成'山のすそ野の色合いを強調するために作ったDim s1 As String, s2 As String, s3 As String, s4 As String, s5 As String, s As StringDim i1 As Long, i2 As Long, i As Long, k As Long, ii As Long
Dim vmax As Double, vmin As Double, v0 As Double, sc As Double, vmax2 As DoubleDim rg As Range, i4 As LongDim vv(3) As DoubleDim cc(3) As LongDim cScale As ColorScaleDim nrow As Long, nx As Long, ny As LongDim obj As Object, wbwb As Workbook, rgg As Range
Dim rr(5) As Long, gg(5) As Long, bb(5) As Long, vvv(5) As DoubleDim vi1 As Long, vi2 As LongDim rrr As Double, ggg As Double, bbb As DoubleDim v4 As Double, v5 As Double, v6 As Double
Dim ppAp As PowerPoint.ApplicationDim pp As PowerPoint.PresentationDim sd As PowerPoint.SlideDim ppwin As PowerPoint.DocumentWindowDim ppshprg As PowerPoint.ShapeRangeDim ppshp As PowerPoint.Shape
Dim sss0 As String
sc = 72 / 2.54
Set ppAp = New PowerPoint.ApplicationSet pp = ppAp.Presentations.Add
With ThisWorkbook.Worksheets("Tips")'値のコピーWith .Range("ColorTable0")k = 5For i = 1 To 5rr(i) = .Cells(k, 1).Valuegg(i) = .Cells(k, 2).Valuebb(i) = .Cells(k, 3).Valuevvv(i) = .Cells(k, 6).Valuek = k - 1Next iEnd With
If False ThenSet wbwb = Workbooks.AddWith wbwb.Worksheets(1)For i = 1 To 5 .Cells(i, 4).Value = rr(i).Cells(i, 5).Value = gg(i) .Cells(i, 6).Value = bb(i) .Cells(i, 2).Value = vvv(i) .Cells(i, 1).Interior.Color = RGB(rr(i), gg(i), bb(i))Next iEnd WithEnd If
'使用した色調バーをコピーしておく.Activate.Shapes("Cbar0").SelectSelection.CopyppAp.Activate For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) With ppwin .Activate .View.GotoSlide (pp.Slides.Count) Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) ppshprg(1).Left = 0: ppshprg(1).Top = 0 ThisWorkbook.Worksheets("Tips").Activate ThisWorkbook.Worksheets("Tips").Range("ColorTable0").Select Selection.Copy .Activate Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) End With End If Next.ActivateEnd With
'Exit Sub
With ThisWorkbook.Worksheets("Sheet1").Activates1 = .Range("パラメータ1").Values2 = .Range("パラメータ2").Valuei1 = .Range("パラメータ3").Valuei2 = .Range("パラメータ4").ValueEnd With
For i = i1 To i2s3 = "vmap_" + s2 + "_" + Format(i, "00")sss0 = "DataSheet= " + s1 + vbCrLf + s3 + vbCrLf + "Program= " + ThisWorkbook.Name + vbCrLf + vbCrLfWith Workbooks(s1).Worksheets(s3) Set obj = .Cells.Find("Value=") nrow = obj.Row nx = .Cells(nrow, 2).Value ny = .Cells(nrow, 3).Value
Set rg = .Range(.Cells(nrow + 2, 2), .Cells(nrow + 1 + ny, 1 + nx)) .Activate rg.Select vmin = WorksheetFunction.Min(rg) vmax2 = WorksheetFunction.Max(rg) sss0 = sss0 + "vmax=" + Format(vmax2, "") + vbCrLf sss0 = sss0 + "vmin=" + Format(vmin, "") + vbCrLf sss0 = sss0 + "(max-min)=" + Format(vmax2 - vmin, "") + vbCrLf
' vmax = vmin + 10000' v0 = vmin + 1000 rg.FormatConditions.Delete For Each rgg In rg With rgg v0 = CDbl(.Value) - vmin' vi = 0 vi1 = 0 '2018.12.20 12：43 お昼 修正 For ii = 1 To 5 If vvv(ii) >= v0 Then Exit For End If vi1 = ii Next ii vi2 = vi1 + 1 If vi1 = 5 Then vi2 = 5 'オーバーフロー Else If vi1 = 0 Then vi1 = 1 vi2 = 1 'アンダーフロー End If End If If vi1 = vi2 Then .Interior.Color = RGB(rr(vi1), gg(vi1), bb(vi1)) Else v6 = vvv(vi2) - vvv(vi1) v5 = CDbl(v0) - vvv(vi1) v4 = v5 / v6 rrr = CDbl(rr(vi1)) + CDbl(CDbl(rr(vi2)) - CDbl(rr(vi1))) * v4 ggg = CDbl(gg(vi1)) + CDbl(CDbl(gg(vi2)) - CDbl(gg(vi1))) * v4 bbb = CDbl(bb(vi1)) + CDbl(CDbl(bb(vi2)) - CDbl(bb(vi1))) * v4 .Interior.Color = RGB(CLng(rrr), CLng(ggg), CLng(bbb)) End If End With '(rgg) Next rgg If False Then Set cScale = rg.FormatConditions.AddColorScale(3) rg.FormatConditions(rg.FormatConditions.Count).SetFirstPriority vv(1) = vmin: vv(2) = v0: vv(3) = vmax cc(1) = 8109667: cc(2) = 8711167: cc(3) = 255 With cScale For i4 = 1 To 3 With .ColorScaleCriteria(i4) .Type = xlConditionValueNumber .Value = vv(i4) With .FormatColor .Color = cc(i4) .TintAndShade = 0 End With End With Next i4 End With End If For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) .Activate .View.GotoSlide (pp.Slides.Count) '型抜き用の四角を書く With sd.Shapes.AddShape(msoShapeRectangle, 0, 0, CDbl(nx - 1) * 0.2 * sc, CDbl(ny - 1) * 0.2 * sc) .Name = "型抜き用型" .Fill.Visible = msoFalse .Line.Visible = msoFalse End With End With End If Next .Activate CutCopyMode = False rg.Select: Selection.Copy ppAp.Activate
For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin .Activate .View.GotoSlide (pp.Slides.Count) Set ppshprg = pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) Set ppshp = ppshprg(1) End With With ppshp bxht = CDbl(ny) * 0.2 bxwd = CDbl(nx) * 0.2 .LockAspectRatio = False .Width = bxwd * sc .Height = bxht * sc .Top = bxtp * sc .Left = bxlft * sc .Name = "MainMap" .Top = -0.1 * sc .Left = -0.1 * sc End With Set ppshprg = sd.Shapes.Range(Array("MainMap", "型抜き用型")) ppshprg.Select ppshprg.MergeShapes msoMergeIntersect sd.Shapes(sd.Shapes.Count).Name = s3 + "型抜き後" End If Next With sd.Shapes.AddTextbox(msoTextOrientationHorizontal, 20 * sc, 14 * sc, 10 * sc, 3 * sc) .TextFrame.TextRange.Text = s3 With .TextFrame2.TextRange .ParagraphFormat.Alignment = msoAlignRight .Font.Name = "Times New Roman" .Font.Size = 24 End With End With With sd sss0 = sss0 + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + vbCrLf .NotesPage.Shapes(2).TextFrame.TextRange.Text = sss0 End WithEnd With
Next i
End Sub
Dim vmax As Double, vmin As Double, v0 As Double, sc As Double, vmax2 As DoubleDim rg As Range, i4 As LongDim vv(3) As DoubleDim cc(3) As LongDim cScale As ColorScaleDim nrow As Long, nx As Long, ny As LongDim obj As Object, wbwb As Workbook, rgg As Range
Dim rr(5) As Long, gg(5) As Long, bb(5) As Long, vvv(5) As DoubleDim vi1 As Long, vi2 As LongDim rrr As Double, ggg As Double, bbb As DoubleDim v4 As Double, v5 As Double, v6 As Double
Dim ppAp As PowerPoint.ApplicationDim pp As PowerPoint.PresentationDim sd As PowerPoint.SlideDim ppwin As PowerPoint.DocumentWindowDim ppshprg As PowerPoint.ShapeRangeDim ppshp As PowerPoint.Shape
Dim sss0 As String
sc = 72 / 2.54
Set ppAp = New PowerPoint.ApplicationSet pp = ppAp.Presentations.Add
With ThisWorkbook.Worksheets("Tips")'値のコピーWith .Range("ColorTable0")k = 5For i = 1 To 5rr(i) = .Cells(k, 1).Valuegg(i) = .Cells(k, 2).Valuebb(i) = .Cells(k, 3).Valuevvv(i) = .Cells(k, 6).Valuek = k - 1Next iEnd With
If False ThenSet wbwb = Workbooks.AddWith wbwb.Worksheets(1)For i = 1 To 5 .Cells(i, 4).Value = rr(i).Cells(i, 5).Value = gg(i) .Cells(i, 6).Value = bb(i) .Cells(i, 2).Value = vvv(i) .Cells(i, 1).Interior.Color = RGB(rr(i), gg(i), bb(i))Next iEnd WithEnd If
'使用した色調バーをコピーしておく.Activate.Shapes("Cbar0").SelectSelection.CopyppAp.Activate For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) With ppwin .Activate .View.GotoSlide (pp.Slides.Count) Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) ppshprg(1).Left = 0: ppshprg(1).Top = 0 ThisWorkbook.Worksheets("Tips").Activate ThisWorkbook.Worksheets("Tips").Range("ColorTable0").Select Selection.Copy .Activate Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) End With End If Next.ActivateEnd With
'Exit Sub
With ThisWorkbook.Worksheets("Sheet1").Activates1 = .Range("パラメータ1").Values2 = .Range("パラメータ2").Valuei1 = .Range("パラメータ3").Valuei2 = .Range("パラメータ4").ValueEnd With
For i = i1 To i2s3 = "vmap_" + s2 + "_" + Format(i, "00")sss0 = "DataSheet= " + s1 + vbCrLf + s3 + vbCrLf + "Program= " + ThisWorkbook.Name + vbCrLf + vbCrLfWith Workbooks(s1).Worksheets(s3) Set obj = .Cells.Find("Value=") nrow = obj.Row nx = .Cells(nrow, 2).Value ny = .Cells(nrow, 3).Value
Set rg = .Range(.Cells(nrow + 2, 2), .Cells(nrow + 1 + ny, 1 + nx)) .Activate rg.Select vmin = WorksheetFunction.Min(rg) vmax2 = WorksheetFunction.Max(rg) sss0 = sss0 + "vmax=" + Format(vmax2, "") + vbCrLf sss0 = sss0 + "vmin=" + Format(vmin, "") + vbCrLf sss0 = sss0 + "(max-min)=" + Format(vmax2 - vmin, "") + vbCrLf
' vmax = vmin + 10000' v0 = vmin + 1000 rg.FormatConditions.Delete For Each rgg In rg With rgg v0 = CDbl(.Value) - vmin' vi = 0 vi1 = 0 '2018.12.20 12：43 お昼 修正 For ii = 1 To 5 If vvv(ii) >= v0 Then Exit For End If vi1 = ii Next ii vi2 = vi1 + 1 If vi1 = 5 Then vi2 = 5 'オーバーフロー Else If vi1 = 0 Then vi1 = 1 vi2 = 1 'アンダーフロー End If End If If vi1 = vi2 Then .Interior.Color = RGB(rr(vi1), gg(vi1), bb(vi1)) Else v6 = vvv(vi2) - vvv(vi1) v5 = CDbl(v0) - vvv(vi1) v4 = v5 / v6 rrr = CDbl(rr(vi1)) + CDbl(CDbl(rr(vi2)) - CDbl(rr(vi1))) * v4 ggg = CDbl(gg(vi1)) + CDbl(CDbl(gg(vi2)) - CDbl(gg(vi1))) * v4 bbb = CDbl(bb(vi1)) + CDbl(CDbl(bb(vi2)) - CDbl(bb(vi1))) * v4 .Interior.Color = RGB(CLng(rrr), CLng(ggg), CLng(bbb)) End If End With '(rgg) Next rgg If False Then Set cScale = rg.FormatConditions.AddColorScale(3) rg.FormatConditions(rg.FormatConditions.Count).SetFirstPriority vv(1) = vmin: vv(2) = v0: vv(3) = vmax cc(1) = 8109667: cc(2) = 8711167: cc(3) = 255 With cScale For i4 = 1 To 3 With .ColorScaleCriteria(i4) .Type = xlConditionValueNumber .Value = vv(i4) With .FormatColor .Color = cc(i4) .TintAndShade = 0 End With End With Next i4 End With End If For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) .Activate .View.GotoSlide (pp.Slides.Count) '型抜き用の四角を書く With sd.Shapes.AddShape(msoShapeRectangle, 0, 0, CDbl(nx - 1) * 0.2 * sc, CDbl(ny - 1) * 0.2 * sc) .Name = "型抜き用型" .Fill.Visible = msoFalse .Line.Visible = msoFalse End With End With End If Next .Activate CutCopyMode = False rg.Select: Selection.Copy ppAp.Activate
For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin .Activate .View.GotoSlide (pp.Slides.Count) Set ppshprg = pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) Set ppshp = ppshprg(1) End With With ppshp bxht = CDbl(ny) * 0.2 bxwd = CDbl(nx) * 0.2 .LockAspectRatio = False .Width = bxwd * sc .Height = bxht * sc .Top = bxtp * sc .Left = bxlft * sc .Name = "MainMap" .Top = -0.1 * sc .Left = -0.1 * sc End With Set ppshprg = sd.Shapes.Range(Array("MainMap", "型抜き用型")) ppshprg.Select ppshprg.MergeShapes msoMergeIntersect sd.Shapes(sd.Shapes.Count).Name = s3 + "型抜き後" End If Next With sd.Shapes.AddTextbox(msoTextOrientationHorizontal, 20 * sc, 14 * sc, 10 * sc, 3 * sc) .TextFrame.TextRange.Text = s3 With .TextFrame2.TextRange .ParagraphFormat.Alignment = msoAlignRight .Font.Name = "Times New Roman" .Font.Size = 24 End With End With With sd sss0 = sss0 + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + vbCrLf .NotesPage.Shapes(2).TextFrame.TextRange.Text = sss0 End WithEnd With
Next i
End Sub
With ThisWorkbook.Worksheets("Tips")'値のコピーWith .Range("ColorTable0")
Color Tone
Cbar0
こっちの方が新しいようです。
Private Sub 色の塗りなおし3_Click_New() ' Texture用Mapの作成
Dim s1 As String, s2 As String, s3 As String, s4 As String, s5 As String, s As StringDim i1 As Long, i2 As Long, i As Long, k As Long, ii As Long
Dim vmax As Double, vmin As Double, v0 As Double, sc As Double, vmax2 As DoubleDim rg As Range, i4 As LongDim vv(3) As DoubleDim cc(3) As LongDim cScale As ColorScaleDim nrow As Long, nx As Long, ny As LongDim obj As Object, wbwb As Workbook, rgg As Range
Dim rr As Long, gg As Long, bb As Long, vvv As DoubleDim rr2 As Long, gg2 As Long, bb2 As Long, vvv2 As DoubleDim vi1 As Long, vi2 As LongDim rrr As Double, ggg As Double, bbb As DoubleDim v4 As Double, v5 As Double, v6 As Double
Dim ws As Worksheet, wb As Workbook, flg As BooleanDim ws0 As Worksheet, wb0 As WorkbookDim rg0 As Range, j1 As LongDim nn As LongDim mm As LongDim s0 As String, ss0 As StringDim rg4 As Range, rg5 As Range
Dim ppAp As PowerPoint.ApplicationDim pp As PowerPoint.PresentationDim sd As PowerPoint.SlideDim ppwin As PowerPoint.DocumentWindowDim ppshprg As PowerPoint.ShapeRangeDim ppshp As PowerPoint.Shape
Dim sss0 As String, wb3 As Workbook
Dim iii As Long
sc = 72 / 2.54
Set ws3 = ThisWorkbook.Worksheets("Tips")With ws3
flg = FalseFor Each wb In WorkbooksIf Left(wb.Name, 3) = "map" ThenIf vbYes = MsgBox(wb.Name + "を処理しますか？", vbYesNo) Thenflg = True: Set wb0 = wb: Exit ForEnd IfEnd IfNext wb
If flg = False ThenMsgBox ("処理しません"): Exit SubEnd If
If False Then
'値のコピー'使用した色調バーをコピーしておく
Set ppAp = New PowerPoint.ApplicationSet pp = ppAp.Presentations.Add
ws3.Activate ws3.Shapes("Cbar0").SelectSelection.CopyppAp.Activate For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) With ppwin .Activate .View.GotoSlide (pp.Slides.Count) Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) ppshprg(1).Left = 0: ppshprg(1).Top = 0 ThisWorkbook.Worksheets("Tips").Activate ThisWorkbook.Worksheets("Tips").Range("ColorTable0").Select Selection.Copy .Activate Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) End With End If Next ppwin.ActivateEnd IfEnd With
'.Range("ColorTable0")flg = FalseFor Each ws In wb0.WorksheetsIf ws.Name = "Summary" Thenflg = True: Set ws0 = ws: End IfNext ws
If flg = False ThenMsgBox ("SummarySheetがないので処理しません"): Exit SubEnd If
Set rg = ws0.Range("C7")j1 = rg.Rowi1 = rg.Columni2 = rg.End(xlToRight).Column
For i = i1 To i2s2 = ws0.Cells(j1, i).Values3 = Replace(s2, "Fq_", "vmap_")s1 = wb0.Namesss0 = "DataSheet= " + s1 + vbCrLf + s3 + vbCrLf + "Program= " + ThisWorkbook.Name + vbCrLf + vbCrLf
vmin = ws0.Cells(j1 + 1, i).Value vmax2 = ws0.Cells(j1 + 2, i).Value sss0 = sss0 + "vmax=" + Format(vmax2, "") + vbCrLf sss0 = sss0 + "vmin=" + Format(vmin, "") + vbCrLf sss0 = sss0 + "base=" + Format(ws0.Cells(j1 + 4, i).Value, "") + vbCrLf sss0 = sss0 + "表示上の最大値=" + Format(ws0.Cells(j1 + 6, i).Value, "") + vbCrLf sss0 = sss0 + "表示上の最小値=" + Format(ws0.Cells(j1 + 7, i).Value, "") + vbCrLf sss0 = sss0 + "表示上の最大値と最小値の差=" + Format(ws0.Cells(j + 3, i).Value, "") + vbCrLf vmin = ws0.Cells(j1 + 1, i).Value = ws0.Cells(j1 + 4, i).Value
With wb0.Worksheets(s3) Set obj = .Cells.Find("Value=") nrow = obj.Row nx = .Cells(nrow, 2).Value ny = .Cells(nrow, 3).Value
Set rg = .Range(.Cells(nrow + 2, 2), .Cells(nrow + 1 + ny, 1 + nx)) .Activate rg.Select
rg.FormatConditions.Delete ss0 = "=Tips!R●C1:R○C4"nn = ws3.Range("ColorTable0").Rows.Countmm = 200s0 = Replace(ss0, "●", CStr(mm))s0 = Replace(s0, "○", CStr(mm - 1 + nn))
ThisWorkbook.Names("ColorTableWork").RefersTo = s0 Set rg4 = ws3.Range("ColorTableWork")Set rg5 = ws3.Range("ColorTable0") rg4.Interior.Color = RGB(0, 255, 0)
k = nnFor iii = 1 To nn
rg4.Cells(iii, 1).Value = rg5.Cells(k, 1).Valuerg4.Cells(iii, 2).Value = rg5.Cells(k, 2).Valuerg4.Cells(iii, 3).Value = rg5.Cells(k, 3).Valuerg4.Cells(iii, 4).Value = rg5.Cells(k, 6).Valuek = k - 1Next iii
For Each rgg In rg With rgg v0 = CDbl(.Value) - vmin
vi1 = 0 For ii = 1 To nn If rg4.Cells(ii, 4).Value >= v0 Then 'カラーテーブルの一番小さい値以下->アンダーフロー Exit For End If vi1 = ii Next ii vi2 = vi1 + 1 If vi1 = nn Then vi2 = nn 'オーバーフロー Else If vi1 = 0 Then vi1 = 1 vi2 = 1 'アンダーフロー End If End If If vi1 = vi2 Then rr = CLng(rg4(vi1, 1).Value) gg = CLng(rg4(vi1, 2).Value) bb = CLng(rg4(vi1, 3).Value) .Interior.Color = RGB(rr, gg, bb) Else v6 = rg4(vi2, 4).Value - rg4(vi1, 4).Value v5 = CDbl(v0) - rg4(vi1, 4).Value v4 = v5 / v6 rr = CLng(rg4(vi1, 1).Value) gg = CLng(rg4(vi1, 2).Value) bb = CLng(rg4(vi1, 3).Value) rr2 = CLng(rg4(vi2, 1).Value) gg2 = CLng(rg4(vi2, 2).Value) bb2 = CLng(rg4(vi2, 3).Value) rrr = CDbl(rr) + CDbl(CDbl(rr2) - CDbl(rr)) * v4 ggg = CDbl(gg) + CDbl(CDbl(gg2) - CDbl(gg)) * v4 bbb = CDbl(bb) + CDbl(CDbl(bb2) - CDbl(bb)) * v4 .Interior.Color = RGB(CLng(rrr), CLng(ggg), CLng(bbb)) End If End With '(rgg) Next rgg If False Then For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin ' Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) Set sd = pp.Slides.AddSlide(2, pp.SlideMaster.CustomLayouts(7)) .Activate ' .View.GotoSlide (pp.Slides.Count) .View.GotoSlide (2) '型抜き用の四角を書く With sd.Shapes.AddShape(msoShapeRectangle, 0, 0, CDbl(nx - 1) * 0.2 * sc, CDbl(ny - 1) * 0.2 * sc) .Name = "型抜き用型" .Fill.Visible = msoFalse .Line.Visible = msoFalse End With End With End If Next .Activate CutCopyMode = False rg.Select: Selection.Copy ppAp.Activate
For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin .Activate '.View.GotoSlide (pp.Slides.Count) .View.GotoSlide (2) 'Set ppshprg = pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) Set ppshprg = pp.Slides(2).Shapes.PasteSpecial(ppPasteEnhancedMetafile) Set ppshp = ppshprg(2) End With With ppshp bxht = CDbl(ny) * 0.2 bxwd = CDbl(nx) * 0.2 .LockAspectRatio = False .Width = bxwd * sc .Height = bxht * sc .Top = bxtp * sc .Left = bxlft * sc .Name = "MainMap" .Top = -0.1 * sc .Left = -0.1 * sc End With Set ppshprg = sd.Shapes.Range(Array("MainMap", "型抜き用型")) ppshprg.Select ppshprg.MergeShapes msoMergeIntersect sd.Shapes(sd.Shapes.Count).Name = s3 + "型抜き後" End If Next With sd.Shapes.AddTextbox(msoTextOrientationHorizontal, 20 * sc, 14 * sc, 10 * sc, 3 * sc) .TextFrame.TextRange.Text = s3 With .TextFrame2.TextRange .ParagraphFormat.Alignment = msoAlignRight .Font.Name = "Times New Roman" .Font.Size = 24 End With End With With sd sss0 = sss0 + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + vbCrLf .NotesPage.Shapes(2).TextFrame.TextRange.Text = sss0 End With End IfEnd With
Next i
End Sub
Dim s1 As String, s2 As String, s3 As String, s4 As String, s5 As String, s As StringDim i1 As Long, i2 As Long, i As Long, k As Long, ii As Long
Dim vmax As Double, vmin As Double, v0 As Double, sc As Double, vmax2 As DoubleDim rg As Range, i4 As LongDim vv(3) As DoubleDim cc(3) As LongDim cScale As ColorScaleDim nrow As Long, nx As Long, ny As LongDim obj As Object, wbwb As Workbook, rgg As Range
Dim rr As Long, gg As Long, bb As Long, vvv As DoubleDim rr2 As Long, gg2 As Long, bb2 As Long, vvv2 As DoubleDim vi1 As Long, vi2 As LongDim rrr As Double, ggg As Double, bbb As DoubleDim v4 As Double, v5 As Double, v6 As Double
Dim ws As Worksheet, wb As Workbook, flg As BooleanDim ws0 As Worksheet, wb0 As WorkbookDim rg0 As Range, j1 As LongDim nn As LongDim mm As LongDim s0 As String, ss0 As StringDim rg4 As Range, rg5 As Range
Dim ppAp As PowerPoint.ApplicationDim pp As PowerPoint.PresentationDim sd As PowerPoint.SlideDim ppwin As PowerPoint.DocumentWindowDim ppshprg As PowerPoint.ShapeRangeDim ppshp As PowerPoint.Shape
Dim sss0 As String, wb3 As Workbook
Dim iii As Long
sc = 72 / 2.54
Set ws3 = ThisWorkbook.Worksheets("Tips")With ws3
flg = FalseFor Each wb In WorkbooksIf Left(wb.Name, 3) = "map" ThenIf vbYes = MsgBox(wb.Name + "を処理しますか？", vbYesNo) Thenflg = True: Set wb0 = wb: Exit ForEnd IfEnd IfNext wb
If flg = False ThenMsgBox ("処理しません"): Exit SubEnd If
If False Then
'値のコピー'使用した色調バーをコピーしておく
Set ppAp = New PowerPoint.ApplicationSet pp = ppAp.Presentations.Add
ws3.Activate ws3.Shapes("Cbar0").SelectSelection.CopyppAp.Activate For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) With ppwin .Activate .View.GotoSlide (pp.Slides.Count) Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) ppshprg(1).Left = 0: ppshprg(1).Top = 0 ThisWorkbook.Worksheets("Tips").Activate ThisWorkbook.Worksheets("Tips").Range("ColorTable0").Select Selection.Copy .Activate Set ppshprg = _ pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) End With End If Next ppwin.ActivateEnd IfEnd With
'.Range("ColorTable0")flg = FalseFor Each ws In wb0.WorksheetsIf ws.Name = "Summary" Thenflg = True: Set ws0 = ws: End IfNext ws
If flg = False ThenMsgBox ("SummarySheetがないので処理しません"): Exit SubEnd If
Set rg = ws0.Range("C7")j1 = rg.Rowi1 = rg.Columni2 = rg.End(xlToRight).Column
For i = i1 To i2s2 = ws0.Cells(j1, i).Values3 = Replace(s2, "Fq_", "vmap_")s1 = wb0.Namesss0 = "DataSheet= " + s1 + vbCrLf + s3 + vbCrLf + "Program= " + ThisWorkbook.Name + vbCrLf + vbCrLf
vmin = ws0.Cells(j1 + 1, i).Value vmax2 = ws0.Cells(j1 + 2, i).Value sss0 = sss0 + "vmax=" + Format(vmax2, "") + vbCrLf sss0 = sss0 + "vmin=" + Format(vmin, "") + vbCrLf sss0 = sss0 + "base=" + Format(ws0.Cells(j1 + 4, i).Value, "") + vbCrLf sss0 = sss0 + "表示上の最大値=" + Format(ws0.Cells(j1 + 6, i).Value, "") + vbCrLf sss0 = sss0 + "表示上の最小値=" + Format(ws0.Cells(j1 + 7, i).Value, "") + vbCrLf sss0 = sss0 + "表示上の最大値と最小値の差=" + Format(ws0.Cells(j + 3, i).Value, "") + vbCrLf vmin = ws0.Cells(j1 + 1, i).Value = ws0.Cells(j1 + 4, i).Value
With wb0.Worksheets(s3) Set obj = .Cells.Find("Value=") nrow = obj.Row nx = .Cells(nrow, 2).Value ny = .Cells(nrow, 3).Value
Set rg = .Range(.Cells(nrow + 2, 2), .Cells(nrow + 1 + ny, 1 + nx)) .Activate rg.Select
rg.FormatConditions.Delete ss0 = "=Tips!R●C1:R○C4"nn = ws3.Range("ColorTable0").Rows.Countmm = 200s0 = Replace(ss0, "●", CStr(mm))s0 = Replace(s0, "○", CStr(mm - 1 + nn))
ThisWorkbook.Names("ColorTableWork").RefersTo = s0 Set rg4 = ws3.Range("ColorTableWork")Set rg5 = ws3.Range("ColorTable0") rg4.Interior.Color = RGB(0, 255, 0)
k = nnFor iii = 1 To nn
rg4.Cells(iii, 1).Value = rg5.Cells(k, 1).Valuerg4.Cells(iii, 2).Value = rg5.Cells(k, 2).Valuerg4.Cells(iii, 3).Value = rg5.Cells(k, 3).Valuerg4.Cells(iii, 4).Value = rg5.Cells(k, 6).Valuek = k - 1Next iii
For Each rgg In rg With rgg v0 = CDbl(.Value) - vmin
vi1 = 0 For ii = 1 To nn If rg4.Cells(ii, 4).Value >= v0 Then 'カラーテーブルの一番小さい値以下->アンダーフロー Exit For End If vi1 = ii Next ii vi2 = vi1 + 1 If vi1 = nn Then vi2 = nn 'オーバーフロー Else If vi1 = 0 Then vi1 = 1 vi2 = 1 'アンダーフロー End If End If If vi1 = vi2 Then rr = CLng(rg4(vi1, 1).Value) gg = CLng(rg4(vi1, 2).Value) bb = CLng(rg4(vi1, 3).Value) .Interior.Color = RGB(rr, gg, bb) Else v6 = rg4(vi2, 4).Value - rg4(vi1, 4).Value v5 = CDbl(v0) - rg4(vi1, 4).Value v4 = v5 / v6 rr = CLng(rg4(vi1, 1).Value) gg = CLng(rg4(vi1, 2).Value) bb = CLng(rg4(vi1, 3).Value) rr2 = CLng(rg4(vi2, 1).Value) gg2 = CLng(rg4(vi2, 2).Value) bb2 = CLng(rg4(vi2, 3).Value) rrr = CDbl(rr) + CDbl(CDbl(rr2) - CDbl(rr)) * v4 ggg = CDbl(gg) + CDbl(CDbl(gg2) - CDbl(gg)) * v4 bbb = CDbl(bb) + CDbl(CDbl(bb2) - CDbl(bb)) * v4 .Interior.Color = RGB(CLng(rrr), CLng(ggg), CLng(bbb)) End If End With '(rgg) Next rgg If False Then For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin ' Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7)) Set sd = pp.Slides.AddSlide(2, pp.SlideMaster.CustomLayouts(7)) .Activate ' .View.GotoSlide (pp.Slides.Count) .View.GotoSlide (2) '型抜き用の四角を書く With sd.Shapes.AddShape(msoShapeRectangle, 0, 0, CDbl(nx - 1) * 0.2 * sc, CDbl(ny - 1) * 0.2 * sc) .Name = "型抜き用型" .Fill.Visible = msoFalse .Line.Visible = msoFalse End With End With End If Next .Activate CutCopyMode = False rg.Select: Selection.Copy ppAp.Activate
For Each ppwin In ppAp.Windows If ppwin.Presentation.Name = pp.Name Then With ppwin .Activate '.View.GotoSlide (pp.Slides.Count) .View.GotoSlide (2) 'Set ppshprg = pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile) Set ppshprg = pp.Slides(2).Shapes.PasteSpecial(ppPasteEnhancedMetafile) Set ppshp = ppshprg(2) End With With ppshp bxht = CDbl(ny) * 0.2 bxwd = CDbl(nx) * 0.2 .LockAspectRatio = False .Width = bxwd * sc .Height = bxht * sc .Top = bxtp * sc .Left = bxlft * sc .Name = "MainMap" .Top = -0.1 * sc .Left = -0.1 * sc End With Set ppshprg = sd.Shapes.Range(Array("MainMap", "型抜き用型")) ppshprg.Select ppshprg.MergeShapes msoMergeIntersect sd.Shapes(sd.Shapes.Count).Name = s3 + "型抜き後" End If Next With sd.Shapes.AddTextbox(msoTextOrientationHorizontal, 20 * sc, 14 * sc, 10 * sc, 3 * sc) .TextFrame.TextRange.Text = s3 With .TextFrame2.TextRange .ParagraphFormat.Alignment = msoAlignRight .Font.Name = "Times New Roman" .Font.Size = 24 End With End With With sd sss0 = sss0 + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + vbCrLf .NotesPage.Shapes(2).TextFrame.TextRange.Text = sss0 End With End IfEnd With
Next i
End Sub
Google Sites
Report abuse