使用 Excel 的 vba 在公式内向左移动一列

Question

我有一些包含以下公式的单元格（还有很多，但我只是将其中一个作为示例，它们都遵循使用 + 或 - 等基本操作的相同模式以及某些单元格内的值）

=+$O11+$N11+$M11

我需要将每一列向左移动一列，最终得到类似

=+$N11+$M11+$L11

问题是我已经编写了检测单元格是否有公式或只有值的代码

for each cell in Selection // im using a selection for testing purposes only
   if cell.hasFormula() = true then
   end if
next cell

但我仍在研究如何将所有列引用向左移动一个，我编写的唯一尝试这样做的代码不起作用

auxiliary = "=offset(" + Replace(cell.formula, "=","") + ",0,1)"
cell.formula = auxiliary

更新 1

有些公式只使用 1 个单元格来检查其是否设置，最多 8 个引用的单元格。数字或参考在前面提到的 2 个数字周围移动

更新 2

我发现以下名为 Precedents 的属性返回引用范围，至少如果我将其应用于公式化引用时会这样做，即在第一个示例中，precedents 将返回 $O$11:$M$11

更新 3

除了上述的公式之外，还有两种类型的公式，第一种是带有 Sum 的公式，即

=Sum($R20:$AC20)

还有 IF 即

=IF($BG20=0,1," ")

此公式中的所有单元格引用都必须向左移动 1。

Answer 1

只要覆盖同一个单元格，就可以尝试：

Option Explicit
Sub shiftLeft()
    Dim f As String
    Dim origCol As Long, newCol As Long
    Dim r As Range, c As Range
    Dim re As Object, mc As Object, m As Object
    Dim I As Long, startNum As Long, numChars As Long

Set re = CreateObject("vbscript.regexp")
With re
    .Global = True
    .Pattern = "C\[?(-?\d+)"
End With

Set r = Range(Cells(1, 9), Cells(Rows.Count, 9).End(xlUp))
For Each c In r
    If c.HasFormula = True Then
        f = c.FormulaR1C1
        'Debug.Print f, c.Formula
        If re.test(f) = True Then
            Set mc = re.Execute(f)
            For I = mc.Count To 1 Step -1
                Set m = mc(I - 1)
                startNum = m.firstindex + 1 + Len(m) - Len(m.submatches(0))
                numChars = Len(m.submatches(0))
                newCol = m.submatches(0) - 1
                f = WorksheetFunction.Replace(f, startNum, numChars, newCol)
            Next I
        End If
    End If
    c.FormulaR1C1 = f
    'Debug.Print f, c.Formula & vbLf
Next c

End Sub

我使用正则表达式来查找列名称，其格式为Cnn 或C[nn] 或C[-nn] 然后我们可以从nn 中减去一个来得到新的列号 使用位置和长度来决定放置替换的位置。

如果结果公式引用列 A 左侧的列，则此宏将终止并出现运行时错误 1004。您可能应该添加一个例程，具体取决于您在该实例中要执行的操作。

编辑： 我没有测试以确保Cnn 是有效的单元格地址，而不是NAME。除非您有一些非常不寻常的名称（例如Cnnnnnnnnn），否则大多数情况下这无关紧要，因为与单元格地址冲突的名称将被拒绝，但如果您的C 后面跟着一个大数字，它可能会被接受。如果可能有问题，可以添加该测试。

Answer 2

您可以使用辅助临时工作表复制/粘贴数据/公式，删除第一列（并将公式向左移动一列）并粘贴回来：

Dim tmpSht As Worksheet
Dim rng As Range

Set rng = Selection
Set tmpSht = Worksheets.Add
With rng
    .Copy Destination:=tmpSht.Range(rng.Address).Offset(, -1)
End With

With tmpSht
    .Columns(1).Delete
    .Range(rng.Address).Offset(, -2).Copy Destination:=rng
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
End With

---

或者您可以使用公式对每个单元格进行操作：

Sub main()
    Dim tmpSht As Worksheet
    Dim cell As Range, rng As Range

    Set rng = Selection
    Set tmpSht = Worksheets.Add ' add a "helper" temporary worksheet

    For Each cell In rng.SpecialCells(xlCellTypeFormulas) ' loop through selection cells containing a formula
        ShiftFormulaOneColumnToTheLeft cell, tmpSht
    Next

    'delete "helper" worksheet
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
End Sub

Sub ShiftFormulaOneColumnToTheLeft(rng As Range, hlpSht As Worksheet)
    rng.Copy Destination:=hlpSht.Range("B1") ' copy passed range and paste it to passed "helper" worksheet range "B1"

    With hlpSht ' reference passed "helper" worksheet
        .Columns(1).Delete ' delete referenced worksheet first column and have all its formulas shift one column to the left
        .Range("A1").Copy Destination:=rng ' copy "helper" worksheet "A1" cell (where previous "B1" has ended to) content  to passed range
    End With
End Sub