My First VBA Program

发表于 更新于 分类于 Waline：

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

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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
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