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

由于测试是完全独立的，因此应在复制单元格的指令块结束后关闭“ 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

Answer 2

您已经获得了可接受的答案/解决方案，但是关于此：

（完整的代码中约有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."

从具有很多语句的另一张表进行条件复制不起作用

2 个答案: