调洪试算

'by safe
Sub start()
On Error Resume Next

Range("A1").Select
ActiveCell.FormulaR1C1 = "=MATCH(MAX(R33C12:R48C12),R33C12:R48C12,0)+32"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=MATCH(MAX(R33C1:R48C1),R33C1:R48C1,0)+32"
Range("A5").Select
ActiveCell.FormulaR1C1 = "=MAX(R[-3]C[4]:R[-3]C[134])"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=MAX(RC[3]:RC[133])"
Range("C2:D2").Select
ActiveCell.FormulaR1C1 = "库水位Z(m)"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C3:D3").Select
ActiveCell.FormulaR1C1 = "库容V*104(m3)"
With ActiveCell.Characters(start:=1, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=4, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=7, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=2).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=10, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False

.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=11, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C2:D3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("D1:Y1").Select
ActiveCell.FormulaR1C1 = "Z-V关系曲线"
Range("D1:Y1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("D4:AA4").Select
ActiveCell.FormulaR1C1 = "设计洪水过程(P=1%)"
With ActiveCell.Characters(start:=1,

Length:=7).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=5).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
ActiveCell.FormulaR1C1 = "设计洪水过程(P=1%)"
With ActiveCell.Characters(start:=1, Length:=7).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=5).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("D5").Select
ActiveCell.FormulaR1C1 = "t(h)"
Range("D6").Select
ActiveCell.FormulaR1C1 = "Q"
Range("D5:D6").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin

.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("E7:U7").Select
ActiveCell.FormulaR1C1 = "q-V关系曲线计算表"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C8:E8").Select
ActiveCell.FormulaR1C1 = "库水位Z(m)"
Range("C9:E9").Select
ActiveCell.FormulaR1C1 = "溢洪道堰顶水头H(m)"
Range("C10:E10").Select
ActiveCell.FormulaR1C1 = "溢洪道泄量q溢(m3/s)"
With ActiveCell.Characters(start:=1, Length:=6).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=7, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = True
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=2).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=10, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=11, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnd

erlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("C11:E11").Select
ActiveCell.FormulaR1C1 = "发电洞泄量q电(m3/s)"
With ActiveCell.Characters(start:=1, Length:=6).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=7, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = True
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=2).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=10, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=11, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("C12:E12").Select
ActiveCell.FormulaR1C1 = "总泄流量q(m3/s)"
With ActiveCell.Characters(start:=1, Length:=7).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=9, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = Fal

se
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("C13:E13").Select
ActiveCell.FormulaR1C1 = "库容V*104(m3)"
With ActiveCell.Characters(start:=1, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=4, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=7, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=8, Length:=2).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=10, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=11, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("C8:E13").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBott

om)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
ActiveWindow.SmallScroll Down:=15
Range("A30:M30").Select
ActiveCell.FormulaR1C1 = "水库调洪试算表"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("A31:A32").Select
ActiveCell.FormulaR1C1 = "t(h)"
Range("B31:B32").Select
ActiveCell.FormulaR1C1 = "Q"
Range("C31:C32").Select
ActiveCell.FormulaR1C1 = "△t"
Range("D31:D32").Select
ActiveCell.FormulaR1C1 = "（Q1+Q2)/2"
With ActiveCell.Characters(start:=1, Length:=9).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("E31:E32").Select
ActiveCell.FormulaR1C1 = "(Q1+Q2)*△t/2"
With ActiveCell.Characters(start:=1, Length:=6).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=7, Length:=4).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=11, Length:=2).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = F

alse
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("F31:F32").Select
ActiveCell.FormulaR1C1 = "q"
Range("G31:G32").Select
ActiveCell.FormulaR1C1 = "q1+q2/2"
Range("H31:H32").Select
ActiveCell.FormulaR1C1 = "q1+q2/2*△t"
Range("I31:I32").Select
ActiveCell.FormulaR1C1 = "△V"
Range("J31:J32").Select
ActiveCell.FormulaR1C1 = "V"
Range("K31:K32").Select
ActiveCell.FormulaR1C1 = "Z"
Range("L31:L32").Select
ActiveCell.FormulaR1C1 = "q'"
With ActiveCell.Characters(start:=1, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=2, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("M31:M32").Select
ActiveCell.FormulaR1C1 = "q-q'"
With ActiveCell.Characters(start:=1, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With ActiveCell.Characters(start:=2, Length:=3).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A31:M32").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Bor

ders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("C8:E8").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C9:E9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C10:E10").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C11:E11").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Range("E11").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0

.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C11:E11").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C12:E12").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C13:E13").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge


Range("A31:A32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("B31:B32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C31:C32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("D31:D32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("E31:E32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("F31:F32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0

.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("G31:G32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("H31:H32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("I31:I32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("J31:J32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("K31:K32").Select
With Selection
.Ho

rizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("L31:L32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("M31:M32").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
End Sub
Sub first()
On Error Resume Next
MsgBox "请输入z - v曲线", vbOKOnly, "by safe"
Range("E2").Select
Selection.Font.ColorIndex = 3
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End Sub
Sub second()
On Error Resume Next
ActiveSheet.ChartObjects("Chart 1025").Activate


ActiveWindow.Visible = False

Range("P21").Select
ActiveSheet.ChartObjects("Chart 1025").Activate
ActiveChart.ChartArea.Select
ActiveChart.SeriesCollection(1).XValues = "=Sheet1!R3C5:R3C135"
ActiveChart.SeriesCollection(1).Values = "=Sheet1!R2C5:R2C135"
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = 0
.MaximumScale = Int(Range("B2").Value + 100)
.MinorUnit = 40
.MajorUnit = 100
.Crosses = xlCustom
.CrossesAt = 0
.ReversePlotOrder = False
.Scale

Type = xlLinear
.HasDisplayUnitLabel = True
End With

MsgBox "请输入设计洪水过程", vbOKOnly, "by safe"
Range("E5").Select
Selection.Font.ColorIndex = 3
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

End Sub

Sub third()
On Error Resume Next
Range("f8").Select
Range("F8").Value = InputBox("请输入起调库水位", vbOKOnly, 2941.85)
Range("f9").Select
Range("F9").Value = InputBox("请输入堰顶水头初值", vbOKOnly, 0)
dh = InputBox("请输入堰顶水头增量", vbOKOnly, 1)
Range("F10").Value = InputBox("请输入流量公式", vbOKOnly, "=0.45*10*SQRT(2 * 9.8) * F9 ^ 1.5")


Range("A5").Select
ActiveCell.FormulaR1C1 = "=MAX(R[-3]C[4]:R[-3]C[134])"
Count = Abs(Int(((Range("A5").Value - Range("F8").Value) - 1) / dh)) + 7

Range(Cells(8, Count), Cells(13, Count + 100)).Select
Selection.Delete Shift:=xlToLeft

For a = 7 To Count
Cells(8, a) = Cells(8, a - 1) + dh
Cells(9, a) = Cells(9, a - 1) + dh
Next a

'填充流量公式
Range("F10").Select
Selection.AutoFill Destination:=Range(Cells(10, 6), Cells(10, Count)), Type:=xlFillDefault
Range("F11").Value = InputBox("请输入发电及引水洞总泄量", vbOKOnly, 0)
Range("F11").Select
Selection.AutoFill Destination:=Range(Cells(11, 6), Cells(11, Count)), Type:=xlFillDefault

Range("F12").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Selection.AutoFill Destination:=Range(Cells(12, 6), Cells(12, Count)), Type:=xlFillDefault
Range("F13").Select
ActiveCell.FormulaR1C1 = "=BezierFit(R3C5:R3C100,R2C5:R2C100,R[-5]C,1,""y"")"
Selection.AutoFill Destination:=Range(Cells(13, 6), Cells(13, Count)), Type:=xlFillDefault



Range(Cells(5, 5), Cells(6, Count)).Select
Selection.Copy
Range("A33").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True


j = Range("b1") '总时段数所在行
Rows(j + 1 & ":100").Select
Selection.Delete Shift:=xlUp

Range("J33").Select
ActiveCell.FormulaR1C1 = "=R[-20]C[-4]"
Range("K33").Select
ActiveCell.FormulaR1C1 = "=BezierFit(R2C5:R2C100,R3C5:R3C100,RC[-1],1,""y"")"
Range("L33").Select
ActiveCell.FormulaR1C1 = "=BezierFit(R12C6:R12C100,R13C6:R13C100,RC[-2],1,""y"")"
Range("M33").Select
ActiveCell.FormulaR1C1 = "=RC[-7]-RC[-1]"
'填充公式
Range("F33").Select
ActiveCell.FormulaR1C1 = "=R[-22]C"
Range("F34").Select
Range("C34").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-R[-1]C[-2]"
Range("D34").Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-1]C[-2]:RC[-2])"
Range("E34").Select
ActiveCell.FormulaR1C1 = "=RC[-2]*RC[-1]*60*60/10000"
Range("G34").Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-1]C[-1]:RC[-1])"

Range("H34").Select
ActiveCell.FormulaR1C1 = "=RC[-5]*RC[-1]*3600/10000"
Range("I34").Select
ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"
Range("J34").Select
ActiveCell.FormulaR1C1 = "=R[-1]C+RC[-1]"
Range("K34").Select
ActiveCell.FormulaR1C1 = "=BezierFit(R2C5:R2C100,R3C5:R3C100,RC[-1],1,""y"")"
Range("L34").Select
ActiveCell.FormulaR1C1 = "=BezierFit(R12C6:R12C100,R13C6:R13C100,RC[-2],1,""y"")"
Range("M34").Select
ActiveCell.FormulaR1C1 = "=RC[-7]-RC[-1]"
Range("C34:M34").Select
Selection.AutoFill Destination:=Range("C34:M" & j)


Range("F9：F10").Select
Selection.Font.ColorIndex = 3
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

ActiveSheet.ChartObjects("Chart 1027").Activate
ActiveChart.PlotArea.Select

ActiveChart.SeriesCollection(1).Name = "=""Q-t"""
ActiveChart.SeriesCollection(2).Name = "=""q-t"""
ActiveChart.SeriesCollection(1).XValues = "=Sheet1!R33C1:R150C1"
ActiveChart.SeriesCollection(1).Values = "=Sheet1!R33C2:R150C2"
ActiveChart.SeriesCollection(2).XValues = "=Sheet1!R33C1:R150C1"
ActiveChart.SeriesCollection(2).Values = "=Sheet1!R33C6:R150C6"

l1:
End Sub

Sub fourth()
Dim er As Double

Dim er1 As Double



On Error Resume Next

Range("F34").Value = InputBox("请输入q初值", vbOKOnly, Range("B34") - 1)
er = InputBox("请输入q-q`误差限", vbOKOnly, 0.00001)
er1 = InputBox("请输入最大下泄流量偏离洪水过程线的限值", vbOKOnly, 1)



k = Range("a1") '最大值所在行
j = Range("b1") '总时段数所在行

For i = 34 To j
Range("M" & i).GoalSeek Goal:=er, ChangingCell:=Range("F" & i)

Next i

k = Range("a1") '最大值所在行
Do While (Abs(Range("B" & k) - Range("L" & k)) > er1)
If Range("B" & k) - Range("L" & k) < 0 Then
Rows(k & ":" & k).Select
Selection.Insert Shift:=xlDown
Range("A" & k).Select
ActiveCell.FormulaR1C1 = "=(R[-1]C+R[1]C)/2"
Range("B" & k).Select
ActiveCell.FormulaR1C1 = "=BezierFit(R6C5:R6C100,R5C5:R5C100,RC[-1],1,""y"")"
Range("C" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-2]-R[-1]C[-2]"
Range("D" & k).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-1]C[-2]:RC[-2])"
Range("E" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-2]*RC[-1]*60*60/10000"

Range("F" & k).Value = Range("F" & k + 1).Value

Range("G" & k).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-1]C[-1]:RC[-1])"

Range("H" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-5]*RC[-1]*3600/10000"

Range("I" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"

Range("J" & k).Select
ActiveCell.FormulaR1C1 = "=R[-1]C+RC[-1]"

Range("K" & k).Select
ActiveCell.FormulaR1C1 = "=BezierFit(R2C5:R2C100,R3C5:R3C100,RC[-1],1,""y"")"

Range("L" & k).Select
ActiveCell.FormulaR1C1 = "=BezierFit(R12C6:R12C100,R1

3C6:R13C100,RC[-2],1,""y"")"

Range("M" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-7]-RC[-1]"

Else
k = k + 1
Range(Cells(k, 1), Cells(k, 13)).Select
Selection.Insert Shift:=xlDown
Range("A" & k).Select
ActiveCell.FormulaR1C1 = "=(R[-1]C+R[1]C)/2"
Range("B" & k).Select
ActiveCell.FormulaR1C1 = "=BezierFit(R6C5:R6C100,R5C5:R5C100,RC[-1],1,""y"")"
Range("C" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-2]-R[-1]C[-2]"
Range("D" & k).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-1]C[-2]:RC[-2])"
Range("E" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-2]*RC[-1]*60*60/10000"

Range("F" & k).Value = Range("F" & k + 1).Value

Range("G" & k).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-1]C[-1]:RC[-1])"

Range("H" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-5]*RC[-1]*3600/10000"

Range("I" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"

Range("J" & k).Select
ActiveCell.FormulaR1C1 = "=R[-1]C+RC[-1]"

Range("K" & k).Select
ActiveCell.FormulaR1C1 = "=BezierFit(R2C5:R2C100,R3C5:R3C100,RC[-1],1,""y"")"

Range("L" & k).Select
ActiveCell.FormulaR1C1 = "=BezierFit(R12C6:R12C100,R13C6:R13C100,RC[-2],1,""y"")"

Range("M" & k).Select
ActiveCell.FormulaR1C1 = "=RC[-7]-RC[-1]"
End If

For i = k - 2 To j
Range("M" & i).GoalSeek Goal:=er, ChangingCell:=Range("F" & i)
Next i

Loop

Range(Cells(k, 1), Cells(k, 13)).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

ActiveSheet.ChartObjects("Chart 1027").Activate
ActiveChart.PlotArea.Select

ActiveChart.SeriesCollection(1).Name = "=""Q-t"""
ActiveChart.SeriesCollection(2).Name = "=""q-t"""
ActiveChart.SeriesCollection(1).XValues = "=Sheet1!R33C1:R150C1"
ActiveChart.SeriesCollection(1).Values = "=Sheet1!R33C2:R150C2"
ActiveChart.SeriesCollection(2).XValues = "=Sheet1!R33C1:R150C1"
ActiveChart.SeriesCollection(2).Values = "=Sheet1!R33C6:R150C6"



End Sub

Sub save()
ActiveWorkbook.SaveAs Application.Dialogs(xlDialogSaveAs).Show
End Sub

'贝塞尔插值

'本程序作者: 海底眼(Mr. Dragon Pan) Excel的平滑线散点图，可以根据两组分别代表X-Y坐标的散点数值产生曲线图
' 但是，却没有提供这个曲线图的公式，所以无法查找曲线上的点坐标
' 后来我在以下这个网页找到了详细的说明和示例程序
'..............................................................................
'/Smooth_curve_bezier_example_file.zip
'..............................................................................
' 根据其中采用的算法，进一步增添根据X坐标求Y坐标，或根据Y坐标求X坐标，更切合实际需求
' 这个自定义函数按照Excel的曲线算法(三次贝塞尔分段插值),计算平滑曲线

上任意一点的点坐标
'
' Excel的平滑曲线的大致算法是:
' 给出了两组X-Y数值以后，每一对X-Y坐标称为节点，然后在每两个节点之间画出三次贝塞尔曲线(下面简称曲线)
' 贝塞尔曲线的算法网上有很多资源，这里不介绍了，只作简单说明
' 每条曲线都由四个节点开始，计算出四个贝塞尔控制点，然后根据控制点画出唯一一条曲线
' 假设曲线的源数据是节点1,节点2,节点3,节点4(Dot1,Dot2,Dot3,Dot4)
' 那么贝塞尔控制点的计算如下
' Dot2是第一个控制点,也是曲点的起点，Dot3是第四个控制点也是曲线的终点
'
' 第二个控制点的位置是:
' 过第一个控制点(Dot2,起点)，与Dot1, Dot3的连线平行，且与Dot2距离为 1/6 * 线段Dot1_Dot3的长度
' 假如是图形的第一段曲线，取节点1,1,2,3进行计算,即 Dot2 = Dot1
' 且第二个控制点与第一控制点距离取 1/3 * |Dot1_Dot3|,而不是1/6 * |Dot1_Dot3|
' 假如 1/2 * |Dot2_Dot3| < 1/6 * |Dot1_Dot3|
' 那么第二个控制点与第一控制点距离取 1/2 * |Dot2_Dot3|,而不是1/6 * |Dot1_Dot3|
'
' 第三个控制点的位置是:
' 过第四个控制点(Dot3,终点)，与Dot2, Dot4的连线平行，且与Dot3距离为 1/6 * |Dot2_Dot4|
' 假如是图形的最后一段曲线，取节点Last-2,Last-1,Last,Last进行计算,即 Dot4 = Dot3
' 且第三个控制点与第四控制点距离取 1/3 * |Dot2_Dot4|,而不是1/6 * |Dot2_Dot4|
' 假如 1/2 * |Dot2_Dot3| < 1/6 * |Dot2_Dot4|
' 那么第二个控制点与第一控制点距离取 1/2 * |Dot2_Dot4|,而不是1/6 * |Dot2_Dot4|
'...............................................................................................
' 这个自定义函数的计算流程是
' Step1: 检查输入的X-Y数值是否有错误，如(输入不够三个点，X-Y的数量不一致,起始搜索节点超过范围等等)
' Step2: 从参数指定的节点开始，计算出四个贝塞尔控制点，得到贝塞尔插值多项式方程，
' 然后代入已知的待求数值，看它能不能满足 f(t)=0 有解 (即曲线包含待查数值)
' Step3: 如果 f(t)=0 有解，根据解出来的 t 值计算X-Y坐标，退出程序,否则继续检查下一段曲线
' Step4: 如果所有分段曲线都不包含待查数值，退出程序
'...............................................................................................

Option Base 1 '所有数组的第一个元素编号为1(默认为0)
Type Vector '自定义数据结构(用二维向量代表坐标系里面的点坐标)
x As Double
y As Double
End Type

Const NoError = "No error" '错误提示信息
Const Error1 = "Error: The size of known_x must equal to size of known_y"
Const Error2 = "Error: The size of known_x must equal to or greater than 3"
Const Error3 = "Error: StartKnot

must be >=1 and <=count(known_x)-1"
Const Error4 = "Error: known_value_type must be ""x"",""y"",or ""t"" "
Const Error5 = "Error: When known_value_type is ""t"" , known_value must >=0 and <=1"
Const Error10 = "Error: known_value is not on the curve (defined by given known_x and known_y)"
Const NoRoot = "No Root"
Const MaxErr = 0.00000001
Const MaxLoop = 1000

Dim SizeX, SizeY As Long '输入区域的大小
Dim Dot1 As Vector '输入区域里面，用作计算贝塞尔控制点的四个节点
Dim Dot2 As Vector
Dim Dot3 As Vector
Dim Dot4 As Vector
Dim BezierPt1 As Vector '生成贝塞尔曲线的四个贝塞尔控制点
Dim BezierPt2 As Vector
Dim BezierPt3 As Vector
Dim BezierPt4 As Vector
Dim OffsetTo2 As Vector '第二,三个贝塞尔控制点跟起点，终点的距离关系
Dim OffsetTo3 As Vector

Dim ValueType As Variant '输入待查数值的类型,"x"代表输入的是X坐标，求对应的Y坐标
Dim Interpol_here As Boolean '当前分段曲线是否包含待查数值
Dim key_value, a, b, c, d As Double '贝塞尔曲线插值多项式的系数
Dim t1, t2, t3 As Variant '贝塞尔曲线插值多项式的根
Dim a3, a2, a1, a0 As Double
'-------------------------------------------------------------------------------------------------
'主程序开始，至少要输入三个参数，第一个是X坐标系列，然后是Y坐标系列，第三个是待查数值
'第四个参数是从哪一段曲线开始查找，如果曲线可以返回多个值，那么分别指定起始节点就可以找出全部合要求的点
'第五个参数是待查数值的类型,"x"代表输入x坐标求对应y坐标，"y"则相反,"t"是直接输入贝塞尔插值多项式的参数
'-------------------------------------------------------------------------------------------------
Function BezierFit(known_x, known_y As Range, known_value, Optional StartKnot As Long = 1, Optional known_value_type As Variant = "x") As Variant
On Error Resume Next
Dim j As Long
Dim x1Value, y1Value, x2Value, y2Value, x3Value, y3Value As Variant
Dim ErrorMsg As Variant

ValueType = LCase(known_value_type) '待查数值的类型转化为小写，并赋值到全局变量ValueType
key_value = known_value '待查数值赋值到全局变量key_value

ErrorMsg = ErrorCheck(known_x, known_y, StartKnot) '检查输入错误
If ErrorMsg <> NoError Then '有错误就返回错误信息，退出程序
BezierFit = Array(ErrorMsg, ErrorMsg, ErrorMsg, ErrorMsg, ErrorMsg, ErrorMsg)
Exit Function
End If

For j = StartKnot To SizeX - 1 '从指定的节点开始，没有指定节点就从1开始
Call FindFourDots(known_x, known_y, j) '找出输入X-Y点坐标里面，应该用于计算的四个结点
Call FindFourBezierPoints(Dot1, Dot2, Dot3, Dot4) '根据四个结点计算四个贝塞尔控制点
Call FindABCD

'根据待查数值的类型，和贝塞尔控制点,计算贝塞尔插值多项式的系数
Call Find_t '检查贝塞尔曲线是否包含待查数值
If Interpol_here = True Then Exit For
Next j

If Interpol_here = True Then '计算点坐标，并返回
'以下是由四个贝塞尔控制点决定的,贝塞尔曲线的参数方程
x1Value = (1 - t1) ^ 3 * BezierPt1.x + 3 * t1 * (1 - t1) ^ 2 * BezierPt2.x + 3 * t1 ^ 2 * (1 - t1) * BezierPt3.x + t1 ^ 3 * BezierPt4.x
y1Value = (1 - t1) ^ 3 * BezierPt1.y + 3 * t1 * (1 - t1) ^ 2 * BezierPt2.y + 3 * t1 ^ 2 * (1 - t1) * BezierPt3.y + t1 ^ 3 * BezierPt4.y
x2Value = (1 - t2) ^ 3 * BezierPt1.x + 3 * t2 * (1 - t2) ^ 2 * BezierPt2.x + 3 * t2 ^ 2 * (1 - t2) * BezierPt3.x + t2 ^ 3 * BezierPt4.x
y2Value = (1 - t2) ^ 3 * BezierPt1.y + 3 * t2 * (1 - t2) ^ 2 * BezierPt2.y + 3 * t2 ^ 2 * (1 - t2) * BezierPt3.y + t2 ^ 3 * BezierPt4.y
x3Value = (1 - t3) ^ 3 * BezierPt1.x + 3 * t3 * (1 - t3) ^ 2 * BezierPt2.x + 3 * t3 ^ 2 * (1 - t3) * BezierPt3.x + t3 ^ 3 * BezierPt4.x
y3Value = (1 - t3) ^ 3 * BezierPt1.y + 3 * t3 * (1 - t3) ^ 2 * BezierPt2.y + 3 * t3 ^ 2 * (1 - t3) * BezierPt3.y + t3 ^ 3 * BezierPt4.y
BezierFit = Array(x1Value, y1Value, x2Value, y2Value, x3Value, y3Value)
Else
BezierFit = Array(Error10, Error10, Error10, Error10, Error10, Error10)
End If

End Function

Function ErrorCheck(known_x, known_y, StartKnot) As Variant

ErrorCheck = NoError
SizeX = known_x.Count
SizeY = known_y.Count

If SizeX <> SizeY Then '假如输入的X坐标数目不等于Y坐标数目
ErrorCheck = Error1
Exit Function
End If

If SizeX < 3 Then '输入的X-Y坐标对少于三个
ErrorCheck = Error2
Exit Function
End If

If (StartKnot < 1 Or StartKnot >= SizeX) Then '指定的起始节点超出范围
ErrorCheck = Error3
Exit Function
End If

If (ValueType <> "x" And ValueType <> "y" And ValueType <> "t") Then '输入的待查数值类型不是x, y, t
ErrorCheck = Error4
Exit Function
End If

If ((ValueType = "t" And key_value > 1) Or (ValueType = "t" And keyvalue < 0)) Then ' t 类型的范围是0-1
ErrorCheck = Error5
Exit Function
End If

End Function

Sub FindFourDots(known_x, known_y, j) '根据X-Y数值，及起始节点，找出用于计算的四个结点坐标
On Error Resume Next
If j = 1 Then '第一个结点 Dot2 = Dot1
Dot1.x = known_x(1)
Dot1.y = known_y(1)
Else
Dot1.x = known_x(j - 1)
Dot1.y = known_y(j - 1)
End If

Dot2.x = known_x(j)
Dot2.y = known_y(j)
Dot3.x = known_x(j + 1)
Dot3.y = known_y(j + 1)

If j = SizeX - 1 Then '最后一个结点 Dot4 = Dot3
Dot4.x = Dot3.x
Dot4.y = Dot3.y
Else
Dot4.x = known_x(j + 2)
Dot4.y = known_y(j + 2)
End If
End S

ub

Sub FindFourBezierPoints(Dot1 As Vector, Dot2 As Vector, Dot3 As Vector, Dot4 As Vector)
On Error Resume Next
Dim d12, d23, d34, d13, d14, d24 As Double
d12 = DistAtoB(Dot1, Dot2) '计算平面坐标系上的两点距离
d23 = DistAtoB(Dot2, Dot3)
d34 = DistAtoB(Dot3, Dot4)
d13 = DistAtoB(Dot1, Dot3)
d14 = DistAtoB(Dot1, Dot4)
d24 = DistAtoB(Dot2, Dot4)

BezierPt1 = Dot2
BezierPt4 = Dot3
OffsetTo2 = AsubB(Dot3, Dot1) '向量减法
OffsetTo3 = AsubB(Dot2, Dot4)

If ((d13 / 6 < d23 / 2) And (d24 / 6 < d23 / 2)) Then
If (Dot1.x <> Dot2.x Or Dot1.y <> Dot2.y) Then OffsetTo2 = AmultiF(OffsetTo2, 1 / 6)
If (Dot1.x = Dot2.x And Dot1.y = Dot2.y) Then OffsetTo2 = AmultiF(OffsetTo2, 1 / 3)
If (Dot3.x <> Dot4.x Or Dot3.y <> Dot4.y) Then OffsetTo3 = AmultiF(OffsetTo3, 1 / 6)
If (Dot3.x = Dot4.x And Dot3.y = Dot4.y) Then OffsetTo3 = AmultiF(OffsetTo3, 1 / 3)
ElseIf ((d13 / 6 >= d23 / 2) And (d24 / 6 >= d23 / 2)) Then
OffsetTo2 = AmultiF(OffsetTo2, d23 / 12)
OffsetTo3 = AmultiF(OffsetTo3, d23 / 12)
ElseIf (d13 / 6 >= d23 / 2) Then
OffsetTo2 = AmultiF(OffsetTo2, d23 / 2 / d13)
OffsetTo3 = AmultiF(OffsetTo3, d23 / 2 / d13)
ElseIf (d24 / 6 >= d23 / 2) Then
OffsetTo2 = AmultiF(OffsetTo2, d23 / 2 / d24)
OffsetTo3 = AmultiF(OffsetTo3, d23 / 2 / d24)
End If

BezierPt2 = AaddB(BezierPt1, OffsetTo2) '向量加法
BezierPt3 = AaddB(BezierPt4, OffsetTo3)

End Sub
Function DistAtoB(dota As Vector, dotb As Vector) As Double
DistAtoB = ((dota.x - dotb.x) ^ 2 + (dota.y - dotb.y) ^ 2) ^ 0.5
End Function
Function AaddB(dota As Vector, dotb As Vector) As Vector
On Error Resume Next
AaddB.x = dota.x + dotb.x
AaddB.y = dota.y + dotb.y
End Function
Function AsubB(dota As Vector, dotb As Vector) As Vector
On Error Resume Next
AsubB.x = dota.x - dotb.x
AsubB.y = dota.y - dotb.y
End Function
Function AmultiF(dota As Vector, MultiFactor As Double) As Vector
On Error Resume Next
AmultiF.x = dota.x * MultiFactor
AmultiF.y = dota.y * MultiFactor
End Function

Sub FindABCD()
On Error Resume Next
If ValueType = "x" Then '参数类型是x, 需要解参数方程 f(t) = x，这里设定参数方程的系数
a = -BezierPt1.x + 3 * BezierPt2.x - 3 * BezierPt3.x + BezierPt4.x
b = 3 * BezierPt1.x - 6 * BezierPt2.x + 3 * BezierPt3.x
c = -3 * BezierPt1.x + 3 * BezierPt2.x
d = BezierPt1.x - key_value
End If

If ValueType = "y" Then '参数类型是x, 需要解参数方程 f(t) = y，这里设定参数方程的系数
a = -BezierPt1.y + 3 * BezierPt2.y - 3 * BezierPt3.y + BezierPt4.y
b = 3 * BezierPt1.y - 6 * BezierPt2.y + 3 * BezierPt3.y
c = -3 * BezierPt1.y + 3 * BezierPt2.y
d = BezierPt1.y - key_value
End If
End Sub

Sub Find_t() '计算当 f(t) = 待查数值时, t应该是什么数值
On Error Resume Next
Dim tArr As Variant

Interpol_here = True

If ValueType = "t" Then '待查数值类型为t,那么无需计算
t1 = key_value
t2 = key_