EXCEL公式填充插件开发（VSTO）

? ? ? ? 需要一个填充公式的功能，但是用EXCEL的自动填充功能无法满足需求（可能是不会用），也没有去找相关插件，自己动手写一个，需要其他功能也好再自定义开发。

一、功能：

? ? ? ? 1、补齐一行、一列、矩形区域的公式。一般来说，公式都具有一定的变化规律——行、列变化，只需要知道相邻单元格变化的步长就可以。

? ? ? ? 2、仿写一个区域的单元格到另一个区域。一般来说，也具有1中类似的变化规律。

二、思路：

? ? ? ? 1、补齐一行时，写出左侧两个单元格，从而得出变化规律，填充选定区域剩下的部分即可。

? ? ? ? 2、补齐一列时，写出上方两个单元格。

? ? ? ? 3、补齐区域时，写出左上角三个单元格，从而得出横向、纵向变化规律，填充剩余区域即可。

? ? ? ? 总之，补齐所选区域的单元格需要选定要填充的区域，并在其左上角打样。

? ? ? ? 4、仿写区域时，在目标区域左上角写入公式，通过与源区域左上角对比得到变化规律，而后填充整个目标区域即可。

? ? ? ? 总之，仿写区域需要选定目标区域左上角并写入公式、选定源区域并把公式填充满。

三、实现

? ? ? ? 使用VSTO开发EXCEL插件。写一个简单的解析公式的代码，只需要解析每个公式将其分离为字母、数字、其他几种字符的连续段，计算两个公式的“差”。其他操作都不难了。

? ? ? ? 1、主体代码

Imports Microsoft.Office.Tools.Ribbon

Public Class MyRibbon

    Protected Friend FromRange As Excel.Range
    Protected Friend ToRange As Excel.Range
    Protected Friend FromFormulas As List(Of List(Of String))
    Protected Friend ToFormulas As List(Of List(Of String))

    Private Sub MyRibbon_Load(ByVal sender As System.Object, ByVal e As RibbonUIEventArgs) Handles MyBase.Load
    End Sub

    Private Sub butTo_Click(sender As Object, e As RibbonControlEventArgs) Handles butTo.Click
        Dim xApp As Excel.Application = Globals.ThisAddIn.Application
        Dim xSheet As Excel.Worksheet = xApp.ActiveSheet
        ToRange = xApp.Selection
        ToFormulas = Helper.RangeFormulaToStringArray(ToRange)
        lblToSheetName.Label = "表格：" & xSheet.Name
        lblToStart.Label = "起点：[" & ToRange.Row & "," & ToRange.Column & "]"
        lblToSize.Label = "大小：[" & ToRange.Rows.Count & "," & ToRange.Columns.Count & "]"
    End Sub

    Private Sub butFrom_Click(sender As Object, e As RibbonControlEventArgs) Handles butFrom.Click
        Dim xApp As Excel.Application = Globals.ThisAddIn.Application
        Dim xSheet As Excel.Worksheet = xApp.ActiveSheet
        FromRange = xApp.Selection
        FromFormulas = Helper.RangeFormulaToStringArray(FromRange)
        lblFromSheetName.Label = "表格：" & xSheet.Name
        lblFromStart.Label = "起点：[" & FromRange.Row & "," & FromRange.Column & "]"
        lblFromSize.Label = "大小：[" & FromRange.Rows.Count & "," & FromRange.Columns.Count & "]"
    End Sub

    '一、当公式区域时目标区域左上角时【必须选定完整的目标区域】：
    '1、目标区域为单行，则向右填充，此时要求填写公式区域左侧两个单元格的公式
    '2、目标区域为单列，则向下填充，此时要求填写公式区域上方两个单元格的公式
    '3、目标区域为矩形，则区域填充，此时要求填写公式区域左上三个单元格的公式

    Private Sub butFill_Click(sender As Object, e As RibbonControlEventArgs) Handles butFill.Click
        Dim xApp As Excel.Application = Globals.ThisAddIn.Application
        Dim xSheet As Excel.Worksheet = xApp.ActiveSheet
        ToRange = xApp.Selection
        ToFormulas = Helper.RangeFormulaToStringArray(ToRange)
        If ToRange.Rows.Count = 1 AndAlso ToRange.Columns.Count > 2 Then
            Dim LeftTopFormula As New MyFormula(ToFormulas(0)(0))
            Dim RightFormula As New MyFormula(ToFormulas(0)(1))
            Dim OffsetFormula = RightFormula - LeftTopFormula
            Dim CurFormula = RightFormula
            For col As Integer = 3 To ToRange.Columns.Count     '本地位置编号从1开始
                CurFormula += OffsetFormula
                Helper.SetCellFormulaInRange(ToRange, 1, col, CurFormula.ToString)
            Next
        ElseIf ToRange.Columns.Count = 1 AndAlso ToRange.Rows.Count > 2 Then
            Dim LeftTopFormula As New MyFormula(ToFormulas(0)(0))
            Dim BottomFormula As New MyFormula(ToFormulas(1)(0))
            Dim OffsetFormula = BottomFormula - LeftTopFormula
            Dim CurFormula = BottomFormula
            For row As Integer = 3 To ToRange.Rows.Count
                CurFormula += OffsetFormula
                Helper.SetCellFormulaInRange(ToRange, row, 1, CurFormula.ToString)
            Next
        ElseIf ToRange.Columns.Count > 2 AndAlso ToRange.Rows.Count > 2 Then
            Dim LeftTopFormula As New MyFormula(ToFormulas(0)(0))
            Dim RightFormula As New MyFormula(ToFormulas(0)(1))
            Dim BottomFormula As New MyFormula(ToFormulas(1)(0))
            Dim LeftToRightOffsetFormula = RightFormula - LeftTopFormula
            Dim TopToBottomFormula = BottomFormula - LeftTopFormula
            Dim CurFormula = RightFormula
            '写第一行，然后按最左侧的范例逐行填写剩余的
            For col As Integer = 3 To ToRange.Columns.Count     '本地位置编号从1开始
                CurFormula += LeftToRightOffsetFormula
                Helper.SetCellFormulaInRange(ToRange, 1, col, CurFormula.ToString)
            Next
            For row As Integer = 2 To ToRange.Rows.Count
                For col As Integer = 1 To ToRange.Columns.Count
                    CurFormula = New MyFormula(Helper.CellRangeFormulaToStringArray(ToRange.Rows(row - 1).cells(col)))
                    CurFormula += TopToBottomFormula
                    Helper.SetCellFormulaInRange(ToRange, row, col, CurFormula.ToString)
                Next
            Next
        Else
            '不符合大小规则
        End If
    End Sub

    '二、当公共区域不包含目标区域时【必须选定完整的公式区域、目标区域左上角】：
    '1、此时要求填写完整公式区域、目标区域左上角的公式
    Private Sub butCopyFill_Click(sender As Object, e As RibbonControlEventArgs) Handles butCopyFill.Click
        If FromRange Is Nothing Then
            MsgBox("请选择公式区域")
        ElseIf ToRange Is Nothing Then
            MsgBox("请选择填充区域")
        Else
            '起点不同，进行公式复制
            Dim fromrect As New Drawing.Rectangle(FromRange.Column, FromRange.Row, FromRange.Columns.Count, FromRange.Rows.Count)
            Dim torect As New Drawing.Rectangle(ToRange.Column, ToRange.Row, ToRange.Columns.Count, ToRange.Rows.Count)
            If FromRange.Worksheet.Name = ToRange.Worksheet.Name AndAlso fromrect.IntersectsWith(torect) Then
                MsgBox("进行区域复制仿写时，公式区域与目标区域不能重合")
            Else
                ToRange = ToRange.Resize(FromRange.Rows.Count, FromRange.Columns.Count)
                Dim FromLeftTopFormula As New MyFormula(FromFormulas(0)(0))
                Dim ToLeftTopFormula As New MyFormula(ToFormulas(0)(0))
                Dim RangeOffset = ToLeftTopFormula - FromLeftTopFormula
                Dim CurFormula As MyFormula
                For row As Integer = 1 To FromRange.Rows.Count
                    For col As Integer = 1 To FromRange.Columns.Count
                        CurFormula = New MyFormula(FromFormulas(row - 1)(col - 1)) + RangeOffset
                        Helper.SetCellFormulaInRange(ToRange, row, col, CurFormula.ToString)
                    Next
                Next
            End If
        End If
    End Sub

    Private Sub butAbout_Click(sender As Object, e As RibbonControlEventArgs) Handles butAbout.Click
        MsgBox("开源地址：https://blog.csdn.net/zcsor" & vbCrLf & vbCrLf & "                                                            作者 zc", MsgBoxStyle.OkOnly, "公式填充")
    End Sub

End Class

????????代码中按照前述思路，设定几个按钮和标签的行为，实现公式的仿写。

????????2、其他部分

Public Class Helper
    ''' <summary>
    ''' 将公式值写入到区域内制定的单元格
    ''' </summary>
    ''' <param name="Range">选定的区域</param>
    ''' <param name="RowOfRange">区域内从1开始的行号（相对值）</param>
    ''' <param name="ColOfRange">区域内从1开始的列号（相对值）</param>
    ''' <param name="Formula">公式内容</param>
    Shared Sub SetCellFormulaInRange(Range As Excel.Range, RowOfRange As Integer, ColOfRange As Integer, Formula As String)
        CType(CType(Range.Rows(RowOfRange), Excel.Range).Cells(ColOfRange), Excel.Range).Formula = Formula
    End Sub

    ''' <summary>
    ''' 将选定区域的公式转换成二维字符串列表
    ''' </summary>
    ''' <param name="Range">选定的区域</param>
    ''' <returns></returns>
    Shared Function RangeFormulaToStringArray(Range As Excel.Range) As List(Of List(Of String))
        Dim Formulas = New List(Of List(Of String))
        If Range Is Nothing Then
            MsgBox("请选择一个连续区域")
        Else
            Dim f = Range.FormulaLocal
            If f Is Nothing Then
                '没有选定
            ElseIf TypeOf f Is String Then      '只选择一个单元格时
                Formulas.Add(New List(Of String)({f}))
            ElseIf TypeOf f Is Object(,) Then   '选定若干单元格时
                Dim arr As Object(,) = f
                For row As Integer = 1 To arr.GetLength(0)
                    Dim rlist As New List(Of String)
                    For col As Integer = 1 To arr.GetLength(1)
                        rlist.Add(arr(row, col))
                    Next
                    Formulas.Add(rlist)
                Next
            Else
                MsgBox("请选择一个连续区域。")
            End If
        End If
        Return Formulas
    End Function

    Shared Function CellRangeFormulaToStringArray(cell As Excel.Range) As String
        Dim result As String = String.Empty
        If cell Is Nothing Then
            MsgBox("请选择一个单元格")
        Else
            result = cell.FormulaLocal
        End If
        Return result
    End Function

End Class

? ? ? ? 实现了一些基础功能，把一个或多个单元格的公式转化为二维list。实际上，这个实现在后来并没有大量使用，是可以舍弃的。

Imports QYExcelFill.MyFormula

Public Class MyFormula

    Public Class MyOffset
        Public Offset As New List(Of Integer)
    End Class

    Private Formula As List(Of String)

    Sub New()
        Formula = New List(Of String)
    End Sub

    Sub New(FormulaString As String)
        Formula = FormulaAnalysis(FormulaString)
    End Sub

    Public Overrides Function ToString() As String
        Dim result As String = String.Empty
        For Each s In Formula
            result += s
        Next
        Return result
    End Function

    Private Shared Function FormulaAnalysis(FormulaString As String) As List(Of String)
        Dim result = New List(Of String)
        '字母划分时分隔符为符号、数字，即只字母进行连续；数字划分时为仅数字连续
        If FormulaString IsNot Nothing AndAlso FormulaString <> String.Empty Then
            Dim tmp As String = FormulaString(0)
            Dim lastType As Integer = GetCharType(FormulaString(0))
            Dim curType As Integer = 0
            For i As Integer = 1 To FormulaString.Length - 1
                curType = GetCharType(FormulaString(i))
                If lastType = curType Then
                    tmp &= FormulaString(i)
                Else
                    result.Add(tmp)
                    tmp = FormulaString(i)
                    lastType = curType
                End If
            Next
            result.Add(tmp)
        End If
        Return result
    End Function

    Public Shared Operator +(x As MyFormula, y As MyOffset) As MyFormula
        Dim result As New MyFormula
        If x.Formula.Count <> y.Offset.Count Then
            MsgBox("进行加法的两个公式格式不统一")
        Else
            For i As Integer = 0 To x.Formula.Count - 1
                If y.Offset(i) = 0 Then     '一样的结果也是一样的
                    result.Formula.Add(x.Formula(i))
                Else
                    If IsNumeric(x.Formula(i)) Then     '是数字的直接做加法
                        result.Formula.Add(CInt(x.Formula(i)) + y.Offset(i))
                    Else                                '不是数字的转为数字，加法之后转换为字符
                        Dim xnum As Integer = ColName2Num(x.Formula(i))
                        result.Formula.Add(ColNum2Name(xnum + y.Offset(i)))
                    End If
                End If
            Next
        End If
        Return result
    End Operator

    Public Shared Operator -(x As MyFormula, y As MyFormula) As MyOffset
        Dim result As New MyOffset
        If x.Formula.Count <> y.Formula.Count Then
            MsgBox("进行减法的两个公式格式不统一")
        Else
            For i As Integer = 0 To x.Formula.Count - 1
                If x.Formula(i) = y.Formula(i) Then     '一样的结果也是一样的
                    result.Offset.Add(0)
                Else
                    If IsNumeric(x.Formula(i)) Then     '是数字的直接做减法
                        result.Offset.Add(CInt(x.Formula(i)) - CInt(y.Formula(i)))
                    Else                                '不是数字的转为数字
                        result.Offset.Add(ColName2Num(x.Formula(i)) - ColName2Num(y.Formula(i)))
                    End If
                End If
            Next
        End If
        Return result
    End Operator

    Private Shared Function GetCharType(str As String) As Integer
        If IsNumeric(str) Then
            Return 1
        ElseIf (Asc("a") <= Asc(str) AndAlso Asc(str) <= Asc("z")) OrElse (Asc("A") <= Asc(str) AndAlso Asc(str) <= Asc("Z")) Then
            Return 2
        Else
            Return 3
        End If
    End Function

    Private Shared Function ColNum2Name(iCol As Integer) As String
        Dim a, b As Integer
        Dim result = ""
        Do While iCol > 0
            a = Int((iCol - 1) / 26)
            b = (iCol - 1) Mod 26
            result = Chr(b + 65) & result
            iCol = a
        Loop
        Return result
    End Function

    Private Shared Function ColName2Num(sColName As String) As Integer
        Dim result As Integer = 0
        For i As Integer = 0 To sColName.Length - 1
            result = result * 26 + CInt(Asc(sColName(i))) - CInt(Asc("A")) + 1
        Next
        Return result
    End Function

End Class

????????实现了公式的简单解析，重载了+-运算符，实现了对公式的解析、加减运算。

? ? ? ? 整体来说代码非常简单，但是实现的不怎么好，实行1+1+1+1+1+1....工作制，呵。也许快被各种琐事淹死了。