3 sütunu doğrulayıp kopyalamak?

[Abdilaka]

Merhaba 3 koşullu bir kopyalama işleminde sorun yaşıyorum kullandığım kodları ekliyorum.

F sütunundaki değer 10-25 arası olanları diğer sayfaya kopyalayabiliyorum ama F değeri 10-25 arası olanlardan sadece G ve H sütunu 100 üstü olanları kopyalayamıyorum.

Yardımcı olur musunuz?

Sub Evn()
    Dim s1 , s2 , s3 As Worksheet
    Dim fdeger As Range
    Dim gdeger As Range
    
    Dim satır As Integer
    satır = 2
      
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Set s3 = Sheets("Sayfa3")

    Application.ScreenUpdating = False
    
    For Each fdeger In s1.Range("F2:F" & s1.Range("F650536").End(3).Row)
    
   
   
    If (fdeger.Value < 25 And fdeger.Value >= 10) Then
       
     '  Set gdeger= Cells(Selection.Row, 7)

         '   If gdeger.Value >100 Then
         
                  satır = satır + 1
                  fdeger.EntireRow.Copy
                  s2.Select
                  Cells(satır, 1).PasteSpecial
                   Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       '      End If   
    
                
    End If
   
    Next fdeger
    
    [a2].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
       
End Sub

 

[PLİNT]

Merhaba 3 koşullu bir kopyalama işleminde sorun yaşıyorum kullandığım kodları ekliyorum.

F sütunundaki değer 10-25 arası olanları diğer sayfaya kopyalayabiliyorum ama F değeri 10-25 arası olanlardan sadece G ve H sütunu 100 üstü olanları kopyalayamıyorum.

Merhaba
Kodlarınızdaki ilgili satırı aşağıdaki mavi bölüm ile değiştirip denermisiniz?
Şart "G" ve "H" hücresinden sadece biri içinse değişelim

[SIZE="2"]'...
'...kodlar
'......
    Application.ScreenUpdating = False
    
    For Each fdeger In s1.Range("F2:F" & s1.Range("F650536").End(3).Row)
    
   
   
 [COLOR="Blue"]   If fdeger.Value < 25 And fdeger.Value >= 10 And s1.Cells(fdeger.Row, "G").Value > 100 And _
    s1.Cells(fdeger.Row, "H").Value > 100 Then[/COLOR]
     '  Set gdeger= Cells(Selection.Row, 7)

         '   If gdeger.Value >100 Then
         
                  satır = satır + 1
'...
'......
[/SIZE]

 

[Abdilaka]

Merhaba
Kodlarınızdaki ilgili satırı aşağıdaki mavi bölüm ile değiştirip denermisiniz?
Şart "G" ve "H" hücresinden sadece biri içinse değişelim

[SIZE="2"]'...
'...kodlar
'......
    Application.ScreenUpdating = False
    
    For Each fdeger In s1.Range("F2:F" & s1.Range("F650536").End(3).Row)
    
   
   
 [COLOR="Blue"]   If fdeger.Value < 25 And fdeger.Value >= 10 And s1.Cells(fdeger.Row, "G").Value > 100 And _
    s1.Cells(fdeger.Row, "H").Value > 100 Then[/COLOR]
     '  Set gdeger= Cells(Selection.Row, 7)

         '   If gdeger.Value >100 Then
         
                  satır = satır + 1
'...
'......
[/SIZE]

Çok teşekkür ederim çalışıyor. Büyük bi data var hata yapıyorsam da formülde yapıyorumdur. Şu şekilde sorunsuz

For Each deger In s1.Range("A2:A" & s1.Range("A650536").End(3).Row)
     
    If (s1.Cells(deger.Row, "F").Value < 100000 And s1.Cells(deger.Row, "F").Value >= 25000 _
    And s1.Cells(deger.Row, "G").Value < 1000000) And s1.Cells(deger.Row, "I").Value < 1000000 Then
    
    satır = satır + 1
    deger.EntireRow.Copy
    s3.Select
    Cells(satır, 1).PasteSpecial
     
     ElseIf (s1.Cells(deger.Row, "F").Value < 25000 And s1.Cells(deger.Row, "F").Value >= 0 And _
     s1.Cells(deger.Row, "G").Value < 1000000 And s1.Cells(deger.Row, "G").Value >= 250000) And _
      s1.Cells(deger.Row, "I").Value < 1000000 Or _
     (s1.Cells(deger.Row, "F").Value < 25000 And s1.Cells(deger.Row, "F").Value >= 0 And _
     s1.Cells(deger.Row, "I").Value < 1000000 And s1.Cells(deger.Row, "I").Value >= 250000) And _
      s1.Cells(deger.Row, "G").Value < 1000000 Then
    
     satır = satır + 1
    deger.EntireRow.Copy
    s3.Select
    Cells(satır, 1).PasteSpecial
    
    End If