使用VBA尝试操作Excel数据

VBA操作Excel真方便，稍微懂下脑子，做个带UI的记账系统还是很棒的。

下面的代码，基本上把循环、判断、赋值都用上了，基本的Excel操作类也有所涉及。不得不说，微软真是用心呀！贵也是有道理的。

View Code

Private Sub B1_Click()
Dim x As Long
Dim y1 As Long
Dim temp As Long
Dim y As Long
Dim count As Long
''''''''''''''页面初始化'''''''''''''''''
Sheets(2).Range("A1:Z255").Clear
Sheets(3).Range("A1:Z255").Clear
'''''''''''''''''''''''''''''''''''''''''

'''''''''''''复制指向定义''''''''''''''''
count = 1
x = 11
y = 6
temp = x
'''''''''''''''''''''''''''''''''''''''''

'''''''''将所需数据复制到sheet3''''''''''
Do Until (IsEmpty(Cells(x, y).Value))
Sheets(3).Cells(count, 1) = Cells(x, y).Value
x = x + 1
count = count + 1
Loop

x = temp
count = 1
y = y + 1
Do Until (IsEmpty(Cells(x, y).Value))
Sheets(3).Cells(count, 2) = Cells(x, y).Value
x = x + 1
count = count + 1
Loop

x = temp
count = 1
y = 10
Do Until (IsEmpty(Cells(x, y).Value))
Sheets(3).Cells(count, 3) = Cells(x, y).Value
x = x + 1
count = count + 1
Loop

x = temp
count = 1
y = 15
Do Until (IsEmpty(Cells(x, y).Value))
Sheets(3).Cells(count, 4) = Cells(x, y).Value
x = x + 1
count = count + 1
Loop
'''''''''''''''''''''''''''''''''''''''''''''''''''''
count = count - 1  '当前行数
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''合并相同项''''''''''''''''''''''''
With Sheets(3)
For R1 = 1 To count
temp = R1 + 1
If Not IsEmpty(Sheets(3).Cells(R1, 1)) Then
For R2 = temp To count
If (.Cells(R1, 1) = .Cells(R2, 1)) And (.Cells(R1, 2) = .Cells(R2, 2)) And (.Cells(R1, 3) = .Cells(R2, 3)) Then
.Cells(R1, 4).Value = .Cells(R1, 4).Value + .Cells(R2, 4).Value
.Range(.Cells(R2, 1), .Cells(R2, 4)).Clear
End If
Next R2
End If
Next R1
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''转移到sheet2的同时进行第二列排序''''''''''
x = 1
y = 1
For R1 = 1 To count
If Not IsEmpty(Sheets(3).Cells(R1, 1)) Then
Sheets(3).Range(Sheets(3).Cells(R1, 1), Sheets(3).Cells(R1, 4)).Copy Destination:=Sheets(2).Range(Sheets(2).Cells(x, 1), Sheets(2).Cells(x, 4))
Sheets(3).Range(Sheets(3).Cells(R1, 1), Sheets(3).Cells(R1, 4)).Clear
x = x + 1
temp = R1 + 1
For R2 = temp To count
If Sheets(2).Cells(x - 1, 1) = Sheets(3).Cells(R2, 1) Then
If Sheets(2).Cells(x - 1, 2) = Sheets(3).Cells(R2, 2) Then
Sheets(3).Range(Sheets(3).Cells(R2, 1), Sheets(3).Cells(R2, 4)).Copy Destination:=Sheets(2).Range(Sheets(2).Cells(x, 1), Sheets(2).Cells(x, 4))
Sheets(3).Range(Sheets(3).Cells(R2, 1), Sheets(3).Cells(R2, 4)).Clear
x = x + 1
End If
End If
Next R2
y = x
End If
Next R1
count = y - 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''转移到sheet3的同时进行第一列排序'''''''''''''
x = 1
y = 1
For R1 = 1 To count
If Not IsEmpty(Sheets(2).Cells(R1, 1)) Then
Sheets(2).Range(Sheets(2).Cells(R1, 1), Sheets(2).Cells(R1, 4)).Copy Destination:=Sheets(3).Range(Sheets(3).Cells(x, 1), Sheets(3).Cells(x, 4))
Sheets(2).Range(Sheets(2).Cells(R1, 1), Sheets(2).Cells(R1, 4)).Clear
x = x + 1
temp = R1 + 1
For R2 = temp To count
If Sheets(3).Cells(x - 1, 1) = Sheets(2).Cells(R2, 1) Then
Sheets(2).Range(Sheets(2).Cells(R2, 1), Sheets(2).Cells(R2, 4)).Copy Destination:=Sheets(3).Range(Sheets(3).Cells(x, 1), Sheets(3).Cells(x, 4))
Sheets(2).Range(Sheets(2).Cells(R2, 1), Sheets(2).Cells(R2, 4)).Clear
x = x + 1
End If
Next R2
y = x
End If
Next R1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''合并单元格''''''''''''''''''''''''''''
x = 1
Do Until x >= count '合并第一列
y = bijiao(x, count, 1)
Sheets(3).Range(Sheets(3).Cells(x, 3), Sheets(3).Cells(y, 4)).Borders.Item(xlEdgeBottom).Weight = xlMedium
Sheets(3).Range(Sheets(3).Cells(x, 3), Sheets(3).Cells(y, 4)).Borders.Item(xlEdgeTop).Weight = xlMedium
If (y - x) >= 1 Then
Sheets(3).Range(Sheets(3).Cells(x + 1, 1), Sheets(3).Cells(y, 1)).Value = ""
Sheets(3).Range(Sheets(3).Cells(x, 1), Sheets(3).Cells(y, 1)).Merge
Do Until (x >= y)  '合并第二列
y1 = bijiao(x, y, 2)
If (y1 - x) >= 1 Then
Sheets(3).Range(Sheets(3).Cells(x + 1, 2), Sheets(3).Cells(y1, 2)).Value = ""
Sheets(3).Range(Sheets(3).Cells(x, 2), Sheets(3).Cells(y1, 2)).Merge
End If
x = y1 + 1
Loop
End If
x = y + 1
Loop
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''移动到sheet2''''''''''''''''''''''''''
Sheets(3).Range(Sheets(3).Cells(1, 1), Sheets(3).Cells(count, 4)).Copy Destination:=Sheets(2).Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(count + 1, 4))
With Sheets(2)
.Cells(1, 1).Value = "标题1"
.Cells(1, 2).Value = "标题2"
.Cells(1, 3).Value = "标题3"
.Cells(1, 4).Value = "标题4"
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, 4)).Font.Name = "楷体"
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, 4)).Font.Size = 14
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(count + 1, 2)).Font.Name = "楷体"
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(count + 1, 2)).Font.Size = 14
.Range(Sheets(2).Cells(2, 3), Sheets(2).Cells(count + 1, 4)).Font.Name = "Arial"
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(count + 1, 4)).Borders.Item(xlEdgeBottom).Weight = xlMedium
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, 4)).Borders.Item(xlEdgeBottom).Weight = xlMedium
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(count + 1, 4)).Borders.Item(xlInsideVertical).Weight = xlMedium
.Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(count + 1, 2)).Borders.Weight = xlMedium
.Range(Sheets(2).Cells(1, 4), Sheets(2).Cells(count + 1, 4)).Borders.Item(xlEdgeRight).Weight = xlMedium
.Columns(4).NumberFormat = "#0"
.Range("A1:Z255").Columns.AutoFit
.Range("A1:Z255").VerticalAlignment = xlCenter
.Range("A1:Z255").HorizontalAlignment = xlCenter
.Activate
End With
Sheets(3).Range("A1:Z255").Clear
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub

'''''''''''''''''''''''返回相同行数'''''''''''''''''
Function bijiao(ByVal startt As Long, ByVal endd As Long, ByVal lie As Long) As Long
For R1 = startt To endd
If Not Sheets(3).Cells(startt, lie) = Sheets(3).Cells(R1, lie) Then
bijiao = R1 - 1
Exit For
End If
If R1 = endd Then
bijiao = endd
Exit For
End If
Next R1
End Function