for next ile veri aktarmada boş satırlar

[burhancavus61]

aktar sayfasındaki o sütunu evet olan tc noları b sayfası B sütununa alt alta aktarmak istiyorum ama boşluklar oluşuyor. b sütununa sıradan nasıl aktarabilirim kodun o kısmını düzenleyemedim.

 

[Cengiz Demir]

Kodunuzdaki ilgili bölümü aşağıdaki gibi değiştirin.
x=3 demişsiniz o yüzden 3. satırdan başlıyor. 2. satırdan başlamasını istiyorsanız 2 olarak değiştirin.

    For i = 2 To 100
        If s1.Cells(i, "O") = "EVET" Then
        s2.Cells(x, "B").Value = s1.Cells(i, "B")
        x = x + 1
        End If
    Next i

 

[Necdet]

Merhaba,

Döngüyü yanlış kurmuşsunuz. x değerine İ değerini ekliyorsunuz.
Başlangıçta x değerine 1 atarsanız, aşağıdaki kodları kullanabilirsiniz.

    For i = 2 To 100
        If s1.Cells(i, "O") = "EVET" Then
            x = x + 1
        s2.Cells(x, "B").Value = s1.Cells(i, "B")
        End If
    Next i

Geç kalmışım

 

[Korhan Ayhan]

Alternatif olarak FİLTRE yöntemiyla aktarım tekniği kullanılmıştır. Belki kullanmak istersiniz.

Option Explicit

Sub Verileri_Aktar()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    ActiveWorkbook.Unprotect
    
    Sheets("aktar").Range("B2:B" & Rows.Count).ClearContents
    
    With Sheets("veri")
        .Unprotect "61"
        .Range("$B$1:$O$" & Rows.Count).AutoFilter Field:=14, Criteria1:="EVET"
        .Range("B2:B" & .Cells(.Rows.Count, 2).End(3).Row).SpecialCells(xlCellTypeVisible).Copy
         Sheets("aktar").Range("B2").PasteSpecial Paste:=xlPasteValues
         On Error Resume Next
        .ShowAllData
         On Error GoTo 0
        .Protect "61", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
        .EnableSelection = xlUnlockedCells
    End With
    
    ActiveWorkbook.Protect Structure:=True, Windows:=False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With

    MsgBox "Kişiler Bordroya aktarıldı...", vbInformation
End Sub

 

[burhancavus61]

Cevaplarınız için teşekkür ederim sayenizde düzeldi.

 

[burhancavus61]

Teşekkür ederim Korhan hocam deneyeceğim ileride ihtiyacım olabilir hem tekniğini öğrenmiş olurum.