Случайно выберите ячейки цели, не имея возможности нацелиться на одну и ту же ячейку дважды

Question

Я пробовал многократные вещи, и я все еще не могу решить свою проблему.

Что я могу добавить в код, чтобы не иметь возможности нацелить одно и то же значение в диапазоне («A5: G11») дважды и иметь возможность мигать не более 6 значений в диапазоне («A5: G11 ") в то время?

Вот что у меня есть до сих пор.

Private Sub Worksheet_SelectionChange (ByVal Target As Range)

Dim valeur As Range, c As Range, KeyRange As Range 

If Target.Cells.Count > 1 Then 
    Exit Sub 

     ElseIf Not (Intersect(Target, Range("A5:G11")) Is Nothing) Then 
      Target.Interior.ColorIndex = 3 
     Else 

    Exit Sub 
End If 

Set valeur = Range("C14:C19") 

For Each c In valeur.Cells 
    If c.value = "" Then 
     c.value = Target.value 
      Exit Sub 
    End If 
Next c 

On Error Resume Next 

Set KeyRange = Range("C14") 
valeur.Sort Key1:=KeyRange, Order1:=xlAscending 

End Sub

Answer 1

У вас есть хороший старт. Мы можем немного очистить ваш код, используя инструкцию «ElseIf», а не вложенность If's in other If's. Затем, чтобы справиться с проблемой вставки, мы будем использовать цикл For Each.

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 

Dim valeur As Range, C as Range 


If Target.Cells.Count > 1 Then 
    Exit Sub 
ElseIf Not (Intersect(Target, Range("A5:G11")) Is Nothing) Then 
    Target.Interior.ColorIndex = 3 
Else 
    Exit Sub 'No need for the last if statement 
End If 

set valuer=range("C14:C16") 
For each C in valuer.cells 
    if c.value="" then 
     c.value=Target.value 
     exit sub 
    end if 
Next c 

'If get to this step, then the C14:C16 range is full, can put some error handling, reset, etc. 

End Sub 

Вы также могли бы сделать этот последний бит с FOR СЛЕДУЮЩИЙ цикла, используя:

For R=14 to 16 'should DIM R as Integer at the top 
    if Cells(r,3)="" then 
     Cells(r,3).value=Target.value 
     exit sub 
    end if 
Next R 

EDIT: Вопрос был отредактирован так, что вставленные результаты должны начаться в С14, а затем просто продолжают расти ,

В этом случае:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 

Dim R as Integer 


If Target.Cells.Count > 1 Then 
    Exit Sub 
ElseIf Not (Intersect(Target, Range("A5:G11")) Is Nothing) Then 
    Target.Interior.ColorIndex = 3 
Else 
    Exit Sub 'No need for the last if statement 
End If 

R=14 
Do While Cells(R,3)<>"" 
    R=R+1 
Loop 
Cells(R,3)=Target.value 

End Sub 

Answer 2

Попробуйте это:

** Вы должны сначала выбрать ячейки, удерживая клавишу клавиатуры Ctrl, а затем запустить этот метод.

Sub DoCopyBySelectionOrder() 
    Const MAX_SELECTION As Integer = 6 

    Dim oFirstTargetCell As Range 
    Dim oTmpCell As Range 
    Dim oCell As Range 
    Dim sSrcRange As String 
    ' r- for rows, c- for columns 
    Dim r% 
    Dim iCount As Integer 

    r = 0 
    iCount = 0 

    sSrcRange = "A5:G11" 

    Set oFirstTargetCell = ActiveSheet.Range("A14") 

    For Each oCell In Selection 
     If IsEmpty(oCell) = False Then 
      If oCell.Text <> "" Then 
       If Not (Intersect(_ 
         oCell, ActiveSheet.Range(sSrcRange)) Is Nothing) Then 
        ' In the first pass the cell returned will be A14 because 
        ' r is 0 at that point. 
        Set oTmpCell = oFirstTargetCell.Offset(r, 0) 
        oTmpCell.Value = oCell.Value 

        iCount = iCount + 1 
        ' EXIT 
        If iCount >= MAX_SELECTION Then Exit Sub 

        r = r + 1 
       End If 
      End If 
     End If 
    Next 

End Sub