My First VBA Program

之前几度想把VBA系统的学习一下,各种原因,各种情况,每每都是超不过三天的热度,虎头未成,蛇尾便早早不见了。

这次算是幸运,依然未超三天之期,但总算草草点上了一个句号。

短短几行代码,无甚大用,放在这里,权当纪念。

Sub shape()

'确认或新建绘图页面
Dim j
For j = 1 To Sheets.Count
    If Sheets(j).Name = "绘图区" Then
        Worksheets("绘图区").Select
        Exit For
    End If
Next
If j = Sheets.Count + 1 Then
    Sheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "绘图区"
End If

'坐标平移和缩放
Dim dx, dy, zoom
dx = -18683500
dy = 4166700
zoom = 0.3

'油井部分
'获得数据行数
Dim k1
k1 = WorksheetFunction.CountA(Worksheets(1).Range("a1:a60000")) - 2
'定义坐标,x、y为图件对象左上角,xx、yy为井底坐标
ReDim x(0 To k1), y(0 To k1), xx(0 To k1), yy(0 To k1)
'井号
ReDim nam(0 To k1)
'下上半圆数据,r半径,angle产油占半圆比例角度,days开井天数,oil月产油,water月产水
ReDim Dr(0 To k1), Dangle(0 To k1), Ddays(0 To k1), Doil(0 To k1), Dwater(0 To k1)
ReDim Ur(0 To k1), Uangle(0 To k1), Udays(0 To k1), Uoil(0 To k1), Uwater(0 To k1)

For i = 0 To k1
    '读取坐标数据
    xx(i) = Worksheets(1).Cells(i + 2, 2)
    yy(i) = Worksheets(1).Cells(i + 2, 3)
    nam(i) = Worksheets(1).Cells(i + 2, 1)
    '进行坐标平移和缩放
    x(i) = (xx(i) + dx) * zoom
    y(i) = (-1 * yy(i) + dy) * zoom
    '读取下半圆数据
    Ddays(i) = Worksheets(1).Cells(i + 2, 4)
    Doil(i) = Worksheets(1).Cells(i + 2, 5)
    Dwater(i) = Worksheets(1).Cells(i + 2, 6)
    '若关井,跳过半圆绘制
    If Dwater(i) + Doil(i) = 0 Then GoTo next1
    If Ddays(i) = 0 Then GoTo next1
    '计算角度、半径
    Dangle(i) = Doil(i) / (Dwater(i) + Doil(i)) * 180 + 1
    Dr(i) = (Dwater(i) + Doil(i)) / Ddays(i) * 1.2 + 10

    '画下半圆
    '水半圆
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - Dr(i), y(i) - Dr(i) - 1, 2 * Dr(i), 2 * Dr(i)).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = 0
    Selection.ShapeRange.Adjustments.Item(2) = 180
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 240)
    '油半圆
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - Dr(i), y(i) - Dr(i) - 1, 2 * Dr(i), 2 * Dr(i)).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = 180 - Dangle(i)
    Selection.ShapeRange.Adjustments.Item(2) = 180
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
    '填写产量
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x(i) - 30, y(i) + 10, 70, 1).Select
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = WorksheetFunction.Text(Doil(i) / Ddays(i), "#0.00") & "/" _
    & WorksheetFunction.Text((Dwater(i) + Doil(i) / 0.84) / Ddays(i), "#0.00")

next1:

   '读取上半圆数据
    Udays(i) = Worksheets(1).Cells(i + 2, 7)
    Uoil(i) = Worksheets(1).Cells(i + 2, 8)
    Uwater(i) = Worksheets(1).Cells(i + 2, 9)
    '若关井,跳过半圆绘制
    If Uwater(i) + Uoil(i) = 0 Then GoTo next2
    If Udays(i) = 0 Then GoTo next2
    '计算角度、半径
    Uangle(i) = Uoil(i) / (Uwater(i) + Uoil(i)) * 180 + 1
    Ur(i) = (Uwater(i) + Uoil(i)) / Udays(i) * 1.2 + 10

    '画上半圆
    '水半圆
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - Ur(i), y(i) - Ur(i), 2 * Ur(i), 2 * Ur(i)).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = 180
    Selection.ShapeRange.Adjustments.Item(2) = 0
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 240)
    '油半圆
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - Ur(i), y(i) - Ur(i), 2 * Ur(i), 2 * Ur(i)).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = 180
    Selection.ShapeRange.Adjustments.Item(2) = 180 + Uangle(i)
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
    '填写产量
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x(i) - 30, y(i) - 30, 70, 1).Select
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = WorksheetFunction.Text(Uoil(i) / Udays(i), "#0.00") & "/" _
    & WorksheetFunction.Text((Uwater(i) + Uoil(i) / 0.84) / Udays(i), "#0.00")

next2:

    '画井位黑点
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - 2.5, y(i) - 2.5, 5, 5).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = -90
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
    '填写井号
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x(i) + 5, y(i) - 10, 70, 1).Select
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = nam(i)

Next

'水井部分
'获得数据行数
Dim k2
k2 = WorksheetFunction.CountA(Worksheets(2).Range("a1:a60000")) - 2
'定义坐标,x、y为图件对象左上角,xx、yy为井底坐标
ReDim x(0 To k2), y(0 To k2), xx(0 To k2), yy(0 To k2)
'井号
ReDim nam(0 To k2)
'下上半圆数据,r半径,angle产油占半圆比例角度,days开井天数,oil月产油,water月产水
ReDim Dr(0 To k2), Ddays(0 To k2), Dinjection(0 To k2)
ReDim Ur(0 To k2), Udays(0 To k2), Uinjection(0 To k2)

For i = 0 To k2
    '读取坐标数据
    xx(i) = Worksheets(2).Cells(i + 2, 2)
    yy(i) = Worksheets(2).Cells(i + 2, 3)
    nam(i) = Worksheets(2).Cells(i + 2, 1)
    '进行坐标平移和缩放
    x(i) = (xx(i) + dx) * zoom
    y(i) = (-1 * yy(i) + dy) * zoom
    '读取下半圆数据
    Ddays(i) = Worksheets(2).Cells(i + 2, 4)
    Dinjection(i) = Worksheets(2).Cells(i + 2, 5)
    '若关井,跳过半圆绘制
    If Dinjection(i) = 0 Then GoTo next3
    If Ddays(i) = 0 Then GoTo next3
    '计算半径
    Dr(i) = Dinjection(i) / 1.7

    '画下半圆
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - Dr(i), y(i) - Dr(i) - 1, 2 * Dr(i), 2 * Dr(i)).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = 0
    Selection.ShapeRange.Adjustments.Item(2) = 180
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80)
    '填写注水量
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x(i) - 30, y(i) + 10, 70, 1).Select
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = WorksheetFunction.Text(Dinjection(i), "#0")

next3:

    '读取上半圆数据
    Udays(i) = Worksheets(2).Cells(i + 2, 6)
    Uinjection(i) = Worksheets(2).Cells(i + 2, 7)
    '若关井,跳过半圆绘制
    If Uinjection(i) = 0 Then GoTo next4
    If Udays(i) = 0 Then GoTo next4
    '计算半径
    Ur(i) = Uinjection(i) / 1.7

    '画上半圆
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - Ur(i), y(i) - Ur(i), 2 * Ur(i), 2 * Ur(i)).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = 180
    Selection.ShapeRange.Adjustments.Item(2) = 0
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80)
    '填写注水量
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x(i) - 30, y(i) - 30, 70, 1).Select
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = WorksheetFunction.Text(Uinjection(i), "#0")

next4:

    '画井位黑点
    ActiveSheet.Shapes.AddShape(msoShapePie, x(i) - 2.5, y(i) - 2.5, 5, 5).Select
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Adjustments.Item(1) = -90
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
    '填写井号
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x(i) + 5, y(i) - 10, 70, 1).Select
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = nam(i)
Next

End Sub
添加新评论