求一个vba小程序，谢谢

Sub 合并至总表()

 Dim Rng As Range, Rng1 As Range, Rng2 As Range, Sh As Worksheet

 Dim Dic As Object, i1&, j1&, i2&, j2&, K1$, K2$, K3$, i0&

 K1 = "水果": K2 = "纯卖其他1": K3 = "其他2"

 Set Dic = CreateObject("Scripting.Dictionary")

 Application.ScreenUpdating = False

 Application.DisplayAlerts = False

 Application.EnableEvents = False

 For Each Sh 冲雹In Worksheets

  Dic(Sh.Name) = ""

 Next Sh

 If Not Dic.exists("总表") Then

  Worksheets.Add before:=Worksheets(1)

  ActiveSheet.Name = "总表"

 Else

  Worksheets("总表").Cells.ClearContents

 End If

 i0 = 0

 With Worksheets("总表")

  For Each Sh In Worksheets

   If Sh.Name <> .Name Then

    Set Rng = Sh.Cells.Find(what:=K1)

    '总表采用第一个分表的两行表头

    If (Not Rng Is Nothing) And i0 = 0 Then

     Rng.Resize(2, 9).Copy .Cells(1, 1)

     i0 = 2

     j1 = 3: j2 = 3

    End If

    Set Rng1 = Sh.Cells.Find(what:=K2)

    Set Rng2 = Sh.Cells.Find(what:=K3)

    If Rng Is Nothing Or Rng1 Is Nothing Or Rng2 Is Nothing Then

    Else

     Set Rng = Rng.Offset(i0, 0)

     .Cells(j1, 1).Resize(Rng1.Row - Rng.Row, 5) = Rng.Resize(Rng1.Row - Rng.Row, 5).Value

     .Cells(j2, 6).Resize(Rng2.Row - Rng.Row, 4) = Rng.Offset(0, 5).Resize(Rng2.Row - Rng.Row, 散裤帆4).Value

     j1 = j1 + Rng1.Row - Rng.Row

     j2 = j2 + Rng2.Row - Rng.Row

    End If

   End If

  Next Sh

  .Cells(1, 1).Resize(Application.WorksheetFunction.Max(j1, j2) - 1, 9).Borders.LineStyle = xlContinuous

 End With

 Application.EnableEvents = True

 Application.DisplayAlerts = True

 Application.ScreenUpdating = True

 Set Dic = Nothing

End Sub

Sub test()

Dim myStr As String '变量类型定义

myStr = "Hello world"

Msgbox myStr '或者直接 Msgbox "Hello world"

End Sub

这就是一个简单的hello world示例程序，运行后d出对话漏轮框，内和搜庆容为"Hello world"。

VBA定义的过程由唤握Sub开始，End Sub结束。Rem或'之后的内容为注释。

具体请查看excel的VB编辑器（VBE）自带的帮助文件。（excel中按alt+F11快捷键打开VBE）

---