Excel VBA 编程练习
最近做了一个VBA的小case，用于方便excel数据的处理，主要的功能代码记录如下。
1. 根据表单名称从workbook中查找出特定表单：
For Each sitem In ThisWorkbook.Worksheets
If sitem.Name = sname Then
' sitem is the object that we wants
Exit For
End If
Next
2. 复制表单m的特定内容到表单n：
Sheets(m).Range("A10:C11").Copy Sheets(n).Cells(1, 1)3. 删除表单特定区域或者是特定区域的数据验证逻辑规则：
Sheets(m).Range("A10:C11").Delete
Sheets(m).Range("A10:C11").Validation.Delete
4. 添加新的worksheet并更改其名称：
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = sname 'ActiveSheet is the new one
5.具体代码
r = ActiveSheet.UsedRange.Rows.Count
c = ActiveSheet.UsedRange.Columns.Count
Dim i As Integer
Dim j As Integer
Dim sname As String
Dim sperson As String
Dim rgtemp As String
sname = ActiveSheet.Cells(1, 2).Text
sperson = ActiveSheet.Cells(1, 4).Text
If Sheet3.Cells(r, c).Text <> "" Or IsEmpty(sname) Then
MsgBox ("A new sheet (Rig.: " + sname + "; Resp. person: " + sperson + ";) is about to be created.")
Worksheets.Add
ActiveSheet.name = sname
Sheet2.Cells.Copy ActiveSheet.Cells(1, 1)
rgtemp = "B3:E" + Trim(Str(r))
Sheet3.Range(rgtemp).Copy ActiveSheet.Cells(18, 5)
ActiveSheet.Cells(5, 3).Value = sname
rgtemp = "A3:A" + Trim(Str(r))
Sheet3.Range(rgtemp).Copy ActiveSheet.Cells(18, 2)
rgtemp = "A4:E" + Trim(Str(r))
Sheet3.Range(rgtemp).Delete
For i = 2 To 5
Sheet3.Cells(3, i).Value = ""
Next i
Sheet3.Cells(1, 2).Value = ""
Sheet3.Cells(1, 4).Value = ""
Sheet1.Select
lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Range("A" + Trim(Str(lastrow)) + ":BF" + Trim(Str(lastrow))).Copy ActiveSheet.Range("a" & lastrow).Offset(1, 0)
For j = 6 To lastcol
ActiveSheet.Cells(lastrow + 1, j).Value = ""
Next j
ActiveSheet.Cells(lastrow + 1, 2).Value = ""
ActiveSheet.Cells(lastrow + 1, 3).Value = ""
ActiveSheet.Cells(lastrow + 1, 4).Value = sname
ActiveSheet.Cells(lastrow + 1, 5).Value = sperson
MsgBox ("Sheet " + sname + " has been created.")
Else
MsgBox ("There must be some wrong with in your input. Please check it again!")
End If
c = ActiveSheet.UsedRange.Columns.Count
r = ActiveSheet.UsedRange.Rows.Count
c = c + 1 'this statement need to be comment if the template has been updated
For i = 18 To r
ActiveSheet.Cells(i, 3).Select
c_thn = 0
c_ton = 0
For j = 9 To c
temp = ActiveSheet.Cells(i, j).Text
If (temp = "OH" Or temp = "NOH") Then
c_thn = c_thn + 1
End If
Next j
ActiveCell.Value = c_thn
ActiveSheet.Cells(i, 4).Select
For j = 9 To c
temp = ActiveSheet.Cells(i, j).Text
If (temp = "OH" Or temp = "ONH") Then
c_ton = c_ton + 1
End If
Next j
ActiveCell.Value = c_ton
Next i
Dim ofs(12) As Integer
Dim mydata() As String
For j = 0 To 11
ofs(j) = 0
Next j
For j = 9 To c
temp = ActiveSheet.Cells(17, j).Text
mydata() = Split(temp, "/")
Select Case CInt(mydata(0))
Case Is = 1
ofs(0) = ofs(0) + 1
Case Is = 2
ofs(1) = ofs(1) + 1
Case Is = 3
ofs(2) = ofs(2) + 1
Case Is = 4
ofs(3) = ofs(3) + 1
Case Is = 5
ofs(4) = ofs(4) + 1
Case Is = 6
ofs(5) = ofs(5) + 1
Case Is = 7
ofs(6) = ofs(6) + 1
Case Is = 8
ofs(7) = ofs(7) + 1
Case Is = 9
ofs(8) = ofs(8) + 1
Case Is = 10
ofs(9) = ofs(9) + 1
Case Is = 11
ofs(10) = ofs(10) + 1
Case Else
ofs(11) = ofs(11) + 1
End Select
Next j
Dim c_pdp(3) As Integer
For i = 0 To 2
c_pdp(i) = 0
Next i
Dim idx As Integer
idx = 0
Dim leng As Integer
leng = 0
Dim k As Integer
For j = 9 To c
ActiveSheet.Cells(17, j).Select
For k = 18 To r
temp = ActiveSheet.Cells(k, j).Text
If Trim(temp) <> "" Then
c_pdp(0) = c_pdp(0) + 1
If temp = "OH" Then
c_pdp(1) = c_pdp(1) + 1
c_pdp(2) = c_pdp(2) + 1
ElseIf temp = "NOH" Then
c_pdp(1) = c_pdp(1) + 1
ElseIf temp = "ONH" Then
c_pdp(2) = c_pdp(2) + 1
End If
End If
Next k
leng = 0
For i = 0 To idx
leng = leng + ofs(i)
Next i
If j = 8 + leng Then
ActiveSheet.Cells(12, j - ofs(idx) + 1).Value = c_pdp(0)
ActiveSheet.Cells(13, j - ofs(idx) + 1).Value = c_pdp(1)
ActiveSheet.Cells(14, j - ofs(idx) + 1).Value = c_pdp(2)
If c_pdp(0) = 0 Then
ActiveSheet.Cells(10, j - ofs(idx) + 1).Value = "No PM planned"
ActiveSheet.Cells(11, j - ofs(idx) + 1).Value = "No PM planned"
Else
ActiveSheet.Cells(10, j - ofs(idx) + 1).Value = c_pdp(1) / CDbl(c_pdp(0))
ActiveSheet.Cells(11, j - ofs(idx) + 1).Value = c_pdp(2) / CDbl(c_pdp(0))
End If
For i = 0 To 2
c_pdp(i) = 0
Next i
idx = idx + 1
End If
Next j
r = Sheet1.UsedRange.Rows.Count
c = Sheet1.UsedRange.Columns.Count
'c = c + 1 'this statement need to be commented if the template has been updated
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim result As String
Dim thn, ton As Integer
thn = 0
ton = 0
For i = 13 To r
For Each sht In ThisWorkbook.Worksheets
temp = Sheet1.Cells(i, 4).Text
If sht.name = Sheet1.Cells(i, 4).Text Then
sts = sht.Index
Exit For
End If
Next
If IsEmpty(sts) Then
MsgBox ("the sheet is null")
Exit For
End If
ssr = Sheets(sts).UsedRange.Rows.Count
For j = 18 To ssr
thn = thn + Sheets(sts).Cells(j, 3).Value
ton = ton + Sheets(sts).Cells(j, 4).Value
Next j
Sheet1.Cells(i, 2).Value = thn
Sheet1.Cells(i, 3).Value = ton
For j = 6 To c
result = ""
For k = 18 To ssr
temp = Sheets(sts).Cells(k, j + 3).Text
If Trim(temp) <> "" Then
result = result + Sheets(sts).Cells(k, 7).Text + " "
End If
Next k
Sheet1.Cells(i, j).Value = Trim(result)
Next j
Next i Dim r, c As Integer
c = ActiveSheet.UsedRange.Columns.Count
c = c + 1 'this statement need to be commented if the template has been updated
ActiveSheet.Range("I" & 10, "I" & 18).Copy Sheet1.Cells(5, 6)
c = Sheet1.UsedRange.Columns.Count
For j = 1 To c
Sheet1.Cells(13, j).Validation.Delete
Next j