Условное копирование с другого листа со многими утверждениями не работает

Question

Я хотел сэкономить кучу времени с помощью скрипта, поэтому я погуглил несколько способов скопировать некоторые ячейки из листа Excel в другую, если утверждение верно (а в полном коде есть ~ 200 утверждений), но, к сожалению, я получил застрял, и он просто не хочет работать. Первый работает нормально, но другие, где он должен проверить, верно ли утверждение в другой ячейке справа, не будут работать.

Sub Proc1()
Dim value As String, result As String

Value1 = Worksheets("munka4").Range("H6").value
Value2 = Worksheets("munka4").Range("I6").value
Value3 = Worksheets("munka4").Range("J6").value

If Value1 = "Car" Then
 Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10") 
 Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10") 
 Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10") 
 Worksheets("munka4").Range("H9").Copy Worksheets("munka2").Range("B8") 
 Worksheets("munka4").Range("H8").Copy Worksheets("munka2").Range("B12") 
 Worksheets("munka4").Range("H10").Copy Worksheets("munka2").Range("B14") 

 If Value2 = "Car" Then
 Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10") 
 Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10") 
 Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10") 
 Worksheets("munka4").Range("I9").Copy Worksheets("munka2").Range("B8") 
 Worksheets("munka4").Range("I8").Copy Worksheets("munka2").Range("B12")  
 Worksheets("munka4").Range("I10").Copy Worksheets("munka2").Range("B14")  

 If Value3 = "Car" Then
 Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10") 
 Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10") 
 Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10") 
 Worksheets("munka4").Range("J9").Copy Worksheets("munka2").Range("B8") 
 Worksheets("munka4").Range("J8").Copy Worksheets("munka2").Range("B12")  
 Worksheets("munka4").Range("J10").Copy Worksheets("munka2").Range("B14")

 End if 
 End if 
 End if

 End Sub

Answer 1

У вас уже есть приемлемый ответ / решение, но относительно этого:

(а в полном коде ~ 200 операторов)

Если это означает, что вы собираетесь скопировать-вставить оператор If ~ 200 раз и слегка изменить каждый экземпляр (не уверен?), Тогда может пригодиться что-то подобное нижеприведенному (вставка копии не требуется) ).

Option Explicit

Sub CopyCellsFromFirstCarColumn()
    Dim rangeToCheck As Range
    Set rangeToCheck = Worksheets("munka4").Range("H6").Resize(1, 200) ' Assumes 200 checks, and that range is contiguous

    Dim matchResult As Variant
    matchResult = Application.Match("Car", rangeToCheck, 0)

    If IsError(matchResult) Then
        MsgBox ("None of the cells in range '" & rangeToCheck.Address & "' on the sheet '" & rangeToCheck.Parent.Name & "' are 'Car'. Nothing has been copied. Code will stop running now.")
        Exit Sub
    End If

    Dim columnToCopy As Long
    columnToCopy = rangeToCheck.Offset(0, matchResult - 1).Column ' -1 as going from 1-based to 0-based

    ' These cells being copied do not change.
    Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10")
    Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10")
    Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10")

    ' These cells being copied depend on where "Car" was found.
    Worksheets("munka4").Cells(9, columnToCopy).Copy Worksheets("munka2").Range("B8")
    Worksheets("munka4").Cells(8, columnToCopy).Copy Worksheets("munka2").Range("B12")
    Worksheets("munka4").Cells(10, columnToCopy).Copy Worksheets("munka2").Range("B14")

 End Sub

Выше будет скопировано только для первого экземпляра "Car". Я думаю, что это хорошо в вашем случае, как вы сказали: "I know that there would be only one case, but I don't know in which cell."

Answer 2

Поскольку ваши тесты полностью независимы, вы должны закрыть блок кода «if Value» после блока инструкций, чтобы скопировать ячейки заканчиваются. Попробуйте вот так:

Sub Proc1()
Dim value As String, result As String

  Value1 = Worksheets("munka4").Range("H6").value
  Value2 = Worksheets("munka4").Range("I6").value
  Value3 = Worksheets("munka4").Range("J6").value

    If Value1 = "Car" Then
     Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10") 
     Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10") 
     Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10") 
     Worksheets("munka4").Range("H9").Copy Worksheets("munka2").Range("B8") 
     Worksheets("munka4").Range("H8").Copy Worksheets("munka2").Range("B12") 
     Worksheets("munka4").Range("H10").Copy Worksheets("munka2").Range("B14") 
   End if 

     If Value2 = "Car" Then
     Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10") 
     Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10") 
     Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10") 
     Worksheets("munka4").Range("I9").Copy Worksheets("munka2").Range("B8") 
     Worksheets("munka4").Range("I8").Copy Worksheets("munka2").Range("B12")  
     Worksheets("munka4").Range("I10").Copy Worksheets("munka2").Range("B14")  
    End if 

     If Value3 = "Car" Then
     Worksheets("munka4").Range("E6").Copy Worksheets("munka2").Range("F10") 
     Worksheets("munka4").Range("F6").Copy Worksheets("munka2").Range("H10") 
     Worksheets("munka4").Range("D6").Copy Worksheets("munka2").Range("B10") 
     Worksheets("munka4").Range("J9").Copy Worksheets("munka2").Range("B8") 
     Worksheets("munka4").Range("J8").Copy Worksheets("munka2").Range("B12")  
     Worksheets("munka4").Range("J10").Copy Worksheets("munka2").Range("B14")
   End if

End Sub