检查单元格是否有 Excel 中的数据，然后将单元格添加到左侧的列中

Question

如果我在 Excel 中有以下内容：

A  B  C   (columns)
a  b  c   (data)
d  e  f   (data)
g  h  i   (data)
-  -  -   (empty)

以及以下验证下拉菜单：

With rng.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="1,2"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With

首先我需要使用 vba 来检查一个单元格是否有数据，如果有，则在新列/单元格的左侧添加验证下拉列表，如下所示：

  A  B  C  D
1,2  a  b  c
1,2  d  e  f
1,2  g  h  i
 -   -  -  -

在用户从下拉列表中选择一个值之后，我需要第二个宏来根据所选值在现有列的任一侧添加更多列：

  A  B  C  D  E  F  G
  1  a  1  b  1  c  1  (if 1 selected from dropdown)
  2  d  2  e  2  f  2  (if 2 selected from dropdown)
  2  g  2  h  2  i  2  (if 2 selected from dropdown)

我是 vba 的真正初学者，因此非常感谢任何帮助。

======= 编辑 =================================

我已经解决了第一部分，其余部分仍然很痛苦：

Sub changeClass()


    Dim rng As Range
    Dim r As Range
    Set rng = Range(Cells(6, 2), Cells(6, 2).End(xlDown))

    Dim rCell As Range

    For Each rCell In rng.Cells
        rCell.Offset(0, -1).Value = "Data"
    Next rCell

    For Each rCell In rng.Cells
        With rng.Offset(0, -1).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$A$1:$A$3"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    Next rCell


End Sub

还有如何插入新列，但不能插入新数据：

Sub newColumn()


    Dim rng As Range
    Dim crng As Range
    Dim r As Range

    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
    End With

    Set rng = Range(Cells(6, 1), Cells(6, 1).End(xlDown))
    Set crng = Range(Cells(5, 1), Cells(5, LastCol))
    Set drng = Range(Cells(4, 1), Cells(4, LastCol))


    Dim rCell As Range
    Dim cCell As Range
    Dim dCell As Range


    For Each rCell In rng.Cells

            For Each cCell In crng.Cells
                cCell.Offset(-1, 0).Value = "columnMark"
            Next cCell

    Next rCell

    For Each dCell In drng.Cells

            If dCell.Value = "columnMark" Then
            dCell.EntireColumn.Offset(0, 1).Insert
            End If
            dCell.Value = ""

    Next dCell


End Sub

Answer 1

这里是一个例子。粘贴到数据所在的工作表类模块。工作表中的所有更改都会触发过程 Worksheet_Change，因此代码可能应该验证“目标”是否与验证范围相交，如果不相交则退出该过程。如果您多次更改验证组合中的选择，那么它不会删除以前的设置，所以......这只是一个例子:-)。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim targetSheet As Worksheet
    Dim i As Byte
    Dim lastColumn As Byte
    Dim firstColumn As Byte
    Dim actualColumn As Byte

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set targetSheet = Target.Worksheet

    With targetSheet

        firstColumn = Target.Offset(columnoffset:=1).Column
        lastColumn = .Cells(Target.Row, .Columns.Count).End(xlToLeft).Column
        actualColumn = firstColumn

        For i = firstColumn To lastColumn
            If (.Cells(Target.Row, actualColumn).Value <> "") Then

                ' if next cell isn't empty insert new one
                If (.Cells(Target.Row, actualColumn + 1).Value <> "") Then
                    .Cells(Target.Row, actualColumn + 1).Insert Shift:=xlToRight
                End If

                .Cells(Target.Row, actualColumn + 1).Value = Target.Value
                actualColumn = actualColumn + 2

            Else
                actualColumn = actualColumn + 1
            End If
        Next i
    End With

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub