求一个vba小程序，谢谢

求一个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
追问：你果然是大神，666

可以帮你写 私信我

文件呢？