0

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
 -   -  -  -

ユーザーがドロップダウンから値を選択した後、選択した値に応じて、既存の列の両側にさらに列を追加するための2番目のマクロが必要です。

  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
4

1 に答える 1

2

ここに例があります。データが存在するシートクラスモジュールに貼り付けます。プロシージャWorksheet_Changeは、シート内のすべての変更でトリガーされるため、コードは「ターゲット」が検証済みの範囲と交差するかどうかを検証し、交差しない場合はプロシージャを終了する必要があります。また、検証コンボの選択を2回以上変更しても、以前の設定は削除されないため、これは単なる例です:-)。

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
于 2013-03-27T03:09:22.037 に答える