使用VBA尝试操作Excel数据

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

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

View Code 
Private Sub B1_Click()
Dim x As Long
Dim temp As Long
Dim y As Long
Dim count As Long

Sheets(2).Range("A2:Z255").Clear
Sheets(3).Range("A1:Z255").Clear

count = 1
x = 11
y = 6
temp = x

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


count = count - 1
For R1 = 1 To count
    temp = R1 + 1
    For R2 = temp To count
        If Sheets(3).Cells(R1, 1) = Sheets(3).Cells(R2, 1) Then
            If Sheets(3).Cells(R1, 2) = Sheets(3).Cells(R2, 2) Then
                Sheets(3).Cells(R1, 3).Value = Sheets(3).Cells(R1, 3).Value + Sheets(3).Cells(R2, 3).Value
                Sheets(3).Range(Sheets(3).Cells(R2, 1), Sheets(3).Cells(R2, 3)).Clear
            End If
        End If
    Next R2
Next R1


x = 2
y = 2
For R1 = 1 To count + 1
    If Not IsEmpty(Sheets(3).Cells(R1, 1)) Then
        Sheets(3).Range(Sheets(3).Cells(R1, 1), Sheets(3).Cells(R1, 3)).Copy Destination:=Sheets(2).Range(Sheets(2).Cells(x, 1), Sheets(2).Cells(x, 3))
        Sheets(3).Range(Sheets(3).Cells(R1, 1), Sheets(3).Cells(R1, 3)).Clear
        x = x + 1
        temp = R1 + 1
        For R2 = temp To count + 1
            If Sheets(2).Cells(x - 1, 1) = Sheets(3).Cells(R2, 1) Then
                Sheets(3).Range(Sheets(3).Cells(R2, 1), Sheets(3).Cells(R2, 3)).Copy Destination:=Sheets(2).Range(Sheets(2).Cells(x, 1), Sheets(2).Cells(x, 3))
                Sheets(3).Range(Sheets(3).Cells(R2, 1), Sheets(3).Cells(R2, 3)).Clear
                x = x + 1
            End If
        Next R2
        If (x - y) > 1 Then
            Sheets(2).Range(Sheets(2).Cells(x - 1, 1), Sheets(2).Cells(y + 1, 1)).Value = ""
            Sheets(2).Range(Sheets(2).Cells(x - 1, 1), Sheets(2).Cells(y, 1)).Merge
        End If
        y = x
    End If
Next R1

count = x - 1

With Sheets(2)
    .Cells(1, 1).Value = TextBox1.Value
    .Cells(1, 2).Value = TextBox2.Value
    .Cells(1, 3).Value = TextBox3.Value
    .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

下面的代码由于没有使用函数，全是过程式的的代码，极度混乱，好在这次尝试的结果还行。

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
【推广】 免费学中医，健康全家人
原文地址：https://www.cnblogs.com/catmelo/p/2942971.html