Как скопировать диапазон ячеек в значение другой ячейки

Question

Я пишу код, который проходит через заданный диапазон ячеек с a для каждого цикла. если эти вызовы не удовлетворяют утверждению if с указанием «для каждого», мне нужно написать диапазон этой ячейки на другом листе. Ex: ячейки A20 и A36 не соответствуют, поэтому я хочу написать A20 и36 на другом листе. таким образом, у меня будет список всех ячеек, которые требуют attention.Here моего кода ниже:

r = 5 
    Set sht1 = Sheets("DataSheet") 
    Set sht2 = Sheets("DiscrepancyReport") 
On Error GoTo DiscrepancySheetError 
    sht2.Select 
On Error GoTo DataSheetError 
    sht1.Select 
On Error GoTo 0 

     lastr = ActiveSheet.range("A1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row 
     lastr = lastr - 1 

'Column 1: WP 
     Set colrg = range("A3:A" & lastr) 
      For Each cell In colrg 
       If (cell.Value) = 6.01 Or (cell.Value) = 6.03 Or (cell.Value) = 3.04 Or (cell.Value) = 6.27 Then 
       Else 
        '## The following line makes no sense but i wrote it so you understand what i want to do 
        currentcell.range.Copy Destination:=sht2.range("A" & r) 
        ActiveCell.Offset(0, 1).Select 
         ActiveCell.Value = "Not a valid WP" 
        r = r + 1 
       End If 
      Next 

Спасибо заранее!

Answer 1

Я предполагаю, что вы хотите поставить «Не действующий WP» в техническом описании, и нет необходимости использовать Copy:

Sub CollectRanges() 
    r = 5 
    Set sht1 = Sheets("DataSheet") 
    Set sht2 = Sheets("DiscrepancyReport") 
'On Error GoTo DiscrepancySheetError 
    sht2.Select 
'On Error GoTo DataSheetError 
    sht1.Select 
On Error GoTo 0 

     lastr = ActiveSheet.Range("A1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row 
     lastr = lastr - 1 

'Column 1: WP 
     Set colrg = Range("A3:A" & lastr) 
      For Each cell In colrg 
       If (cell.Value) = 6.01 Or (cell.Value) = 6.03 Or (cell.Value) = 3.04 Or (cell.Value) = 6.27 Then 
       Else 
        sht2.Cells(r, 1).Value = cell.Address 
        cell.Offset(0, 1).Value = "Not a valid WP" 
        r = r + 1 
       End If 
      Next 
End Sub 

Answer 2

Вот обновленный код, предполагающий, что ваши данные начинаются с 3-й строки.
Избегайте использования Select/Activate в коде. Смотрите этот link

Sub test() 

    Dim sht1 As Worksheet 
    Dim sht2 As Worksheet 
    Dim r As Long, lastr As Long 

    r = 3 
    Set sht1 = Sheets("DataSheet") 
    Set sht2 = Sheets("DiscrepancyReport") 

    With sht1 
     lastr = .Range("A" & .Rows.Count).End(xlUp).Row 
     If lastr < 3 Then lastr = 3 

     Set colrg = Range("A3:A" & lastr) 
    End With 


    For Each cell In colrg 
     If (cell.Value) = 6.01 Or (cell.Value) = 6.03 Or (cell.Value) = 3.04 Or (cell.Value) = 6.27 Then 
     Else 
      '## The following line makes no sense but i wrote it so you understand what i want to do 
      cell.Copy Destination:=sht2.Range("A" & r) 
      sht2.Range("B" & r) = "Not a valid WP" 
      r = r + 1 
     End If 
    Next 


End Sub 

Answer 3

Вот обновленный код Код Энди и Сантоша -

Sub test() 

Dim sht1 As Worksheet 
Dim sht2 As Worksheet 
Dim r As Long, lastr As Long 

r = 3 
Set sht1 = Sheets("DataSheet") 
Set sht2 = Sheets("DiscrepancyReport") 

With sht1 
    lastr = .Range("A" & .Rows.Count).End(xlUp).Row 
    If lastr < 3 Then lastr = 3 

    Set colrg = Range("A3:A" & lastr) 
End With 


For Each cell In colrg 
    If (cell.Value) <> 6.01 Or (cell.Value) <> 6.03 Or (cell.Value) <> 3.04 Or (cell.Value) <> 6.27 Then 
     '## The following line makes no sense but i wrote it so you understand what i want to do 
     sht2.Range("A" & r).value=Replace(cell.Address, "$", "") 

     'Comment the appropriate one below 

     'If you want this to be written in the 2nd sheet, below is the code, else comment it. 
     sht2.Range("B" & r) = "Not a valid WP" 

     'If you want this to be written in the 1st sheet, below is the code, else comment it. 
     cell.offset(0,1).value = "Not a valid WP" 
     r = r + 1 
    End If 
Next 

End Sub 

Надеюсь, это поможет.