檢查細胞在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過程觸發了工作表中的所有更改，因此如果'Target'與驗證的範圍相交，並且如果不是則退出該過程，也許代碼應該驗證。如果您更改了驗證組合中的選擇，然後再更改一次，那麼它將不會刪除之前的設置，所以......這只是一個例子:-)。

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