求一个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("ScriptingDictionary")

 ApplicationScreenUpdating = False

 ApplicationDisplayAlerts = False

 ApplicationEnableEvents = False

 For Each Sh In Worksheets

  Dic(ShName) = ""

 Next Sh

 If Not Dicexists("总表") Then

  WorksheetsAdd before:=Worksheets(1)

  ActiveSheetName = "总表"

 Else

  Worksheets("总表")CellsClearContents

 End If

 i0 = 0

 With Worksheets("总表")

  For Each Sh In Worksheets

   If ShName <> Name Then

    Set Rng = ShCellsFind(what:=K1)

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

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

     RngResize(2, 9)Copy Cells(1, 1)

     i0 = 2

     j1 = 3: j2 = 3

    End If

    Set Rng1 = ShCellsFind(what:=K2)

    Set Rng2 = ShCellsFind(what:=K3)

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

    Else

     Set Rng = RngOffset(i0, 0)

     Cells(j1, 1)Resize(Rng1Row - RngRow, 5) = RngResize(Rng1Row - RngRow, 5)Value

     Cells(j2, 6)Resize(Rng2Row - RngRow, 4) = RngOffset(0, 5)Resize(Rng2Row - RngRow, 4)Value

     j1 = j1 + Rng1Row - RngRow

     j2 = j2 + Rng2Row - RngRow

    End If

   End If

  Next Sh

  Cells(1, 1)Resize(ApplicationWorksheetFunctionMax(j1, j2) - 1, 9)BordersLineStyle = xlContinuous

 End With

 ApplicationEnableEvents = True

 ApplicationDisplayAlerts = True

 ApplicationScreenUpdating = True

 Set Dic = Nothing

End Sub

用代码实现自动化，界面就是一个按钮，点一下就完成了工资表的计算，或者自动生成工资条等。

这就是 *** 作界面。

Private Sub CommandButton3_Click() '检查填充

 Dim skUArr(1 To 1000, 1 To 3)

 Dim skUGs As Integer

 Dim hH As Integer

 Dim zlHH As Integer

 CellsFind(What:="Weight of box", After:=ActiveCell, LookIn:=xlFormulas _

      , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _

      MatchCase:=False, MatchByte:=False, SearchFormat:=False)Activate

 zlHH = ActiveCellRow '重量所在行号

 skmGs = 0

 hH = 5

 Do While Trim(Cells(hH, 1)Text) <> ""

    skUGs = skUGs + 1

    skUArr(skUGs, 1) = Trim(Cells(hH, 1)Text)

    skUArr(skUGs, 2) = Trim(Cells(hH, 4)Text)

    skUArr(skUGs, 3) = Cells(hH, 10)Value

    hH = hH + 1

 Loop

 Dim fName As String

 Dim SBook As Workbook

 Call SelectFile(fName)

 Set SBook = WorkbooksOpen(fName)

 Dim M_sku As String, M_fnSku As String, M_qty As Integer

 With SBookSheets(1)

    For I = 1 To skUGs

       M_sku = Trim(Cells(5 + I - 1, 1)Text)

       M_fnSku = Trim(Cells(5 + I - 1, 4)Text)

       M_qty = Cells(5 + I - 1, 9)Value

       If skUArr(I, 1) <> M_sku Then

          MsgBox ("第" & I & "条记录的SKU不一致！")

          Exit Sub

       End If

       If skUArr(I, 2) <> M_fnSku Then

          MsgBox ("第" & I & "条记录的FNSKU不一致！")

          Exit Sub

       End If

       If skUArr(I, 3) <> M_qty Then

          MsgBox ("第" & I & "条记录的QTY不一致！")

          Exit Sub

       End If

    Next I

 End With

 Dim qtyArr() As Integer

 Dim boxGs As Integer

 Dim boxArr()

 With ThisWorkbookSheets(1)

    boxGs = Cells(4, 200)End(xlToLeft)Column

    ReDim qtyArr(1 To skUGs, 1 To boxGs)

    ReDim boxArr(1 To 4, 1 To boxGs)

    '读取数量

    For I = 1 To skUGs

       For J = 1 To boxGs

          qtyArr(I, J) = Cells(5 + I - 1, 12 + J - 1)Value

       Next J

    Next I

   '读取box

    For I = 1 To 4

       For J = 1 To boxGs

          boxArr(I, J) = Cells(zlHH + I - 1, 12 + J - 1)Value

       Next J

    Next I

 End With

 '填充

 With SBookSheets(1)

    'Cells(5, 12)Resize(skUGs, boxGs) = qtyArr

    'Cells(zlHH, 12)Resize(4, boxGs) = boxArr

    For I = 1 To skUGs

       For J = 1 To boxGs

          If qtyArr(I, J) > 0 Then

             Cells(5 + I - 1, 12 + J - 1) = qtyArr(I, J)

          End If

       Next J

    Next I

    For I = 1 To 4

       For J = 1 To boxGs

          Cells(zlHH + I - 1, 12 + J - 1) = boxArr(I, J)

       Next J

    Next I

 End With

 SBookSave

 MsgBox ("检查结果OK,填充完成！")

End Sub

这是其中一个按钮的代码，供参考。

以上就是关于求一个vba小程序，谢谢全部的内容，包括:求一个vba小程序，谢谢、vba程序是什么、等相关内容解答，如果想了解更多相关内容，可以关注我们，你们的支持是我们更新的动力！