Tentando fazer um loop em duas colunas e colocar o resultado em uma coluna.
1) o loop está incorreto (sem acertos = errado)
2) a impressão coloca o resultado em duas colunas diferentes ("O" +7 de H e "R" +7 de K).
Private Sub FindValueKH_JN()
'New column O (no 15)
'Find if value starting in column H (no8) is between 207100-208100
'AND if value starting in column K (no11) is between 12700-12729,
' then T2J in column O, else T2N in O
Range("O1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "T2 er Ja eller Nei"
Dim loopRange As Range
'From H to new column O is +7 columns
lastrow1 = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row
'From K to new column O is +4 columns
lastrow2 = ActiveSheet.Cells(Rows.Count, "K").End(xlUp).Row
'loop columns H and K
Set loopRange = Union(Range("H2:H" & lastrow1), Range("K2:K" & lastrow2))
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And _
Left(cell.Value, 5) >= 12700 And Left(cell.Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
End Sub
Suas referências estão incorretas e é por isso que você não está obtendo resultados. Você deseja verificar se há valores específicos em duas colunas separadas, mas, em vez disso, está apenas procurando em uma única célula as duas condições:
For Each cell In loopRangefará um loop por cada célula em seu loopRangeintervalo definido , que contém ambas as colunas.
Você teria que alterar seu código para que ele percorra apenas uma única coluna, como a seguir
Dim loopRange As Range
lastrow = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row 'From H to new column O is +7 columns
Set loopRange = Range("H2:H" & lastrow1) 'loop columns H
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And Left(cell.Offset(, 3).Value, 5) >= 12700 And Left(cell.Offset(, 3).Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
Este artigo é coletado da Internet.
Se houver alguma infração, entre em [email protected] Delete.
deixe-me dizer algumas palavras