Dulu hücreleri aktarma

[mhizlim]

Aktarma işlemini altından başlayarak sorunsuz yapıyorum fakat (a4:f'XX') GİBİ hücrelerini aktarıyor ben sadece bu aralıktaki dolu olanları aktarmak istiyorum. A sütunu sıra numarası fakat b sütünu ile f sütunu arasındaki dolu olanları sıra numarasıyla birlikte aktarılmasını nasıl sağlarız. ( metin olarak hücre biçimi vb. değil)

 

[Ömer]

Merhaba,

Sorunuzu küçük bir örnek dosya ile destekleyip açıklarmısınız.

 

[mhizlim]

Dosyayı ekledim

Merhaba,

Sorunuzu küçük bir örnek dosya ile destekleyip açıklarmısınız.

dosyayı ekledim

 

[apocalyt]

şunu deneyiniz..(ömer hocam ben cevaplamış bulundum kusura kalmayınız.)

Sub yanAKTAR()
Application.ScreenUpdating = False
Range("h4:m1000").ClearContents
For x = 4 To [b1000].End(3).Row
If Range("b" & x) <> "" Then
Range("b" & x & ":" & "f" & x).Copy
If [ı1000].End(3).Row < 3 Then
Range("ı4:m4").PasteSpecial (xlPasteValues)
Else
Range("ı" & [ı1000].End(3).Row + 1 & ":" & "m" & [ı1000].End(3).Row + 1).PasteSpecial (xlPasteValues)
End If
End If
Next x
For y = 4 To [ı1000].End(3).Row
Cells(y, "h") = y - 3
Next y
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[mhizlim]

mersi

mersi ilaç gibi geldi. Fakat birdaha ki sefere yeniden girilen leri aktar dediğimde silip üzerine aktarıyor bunu nasıl altından başlatabilirim

 

[apocalyt]

sadece yapmanız gereken
Range("h4:m1000").ClearContents kodunu silmek...

 

[mhizlim]

sadece yapmanız gereken
Range("h4:m1000").ClearContents kodunu silmek...

Evet kodu silince gidiyor ama sına nosu aynı yeşilde devam ediyor ben her aktardığımda 1 den başlamasını istiyoum.

 

[apocalyt]

kodu bunlarla değiştirin.
Sub yanAKTAR()
Application.ScreenUpdating = False
For x = 4 To [b1000].End(3).Row
If Range("b" & x) <> "" Then
Range("b" & x & ":" & "f" & x).Copy
If [ı1000].End(3).Row < 3 Then
Range("ı4:m4").PasteSpecial (xlPasteValues)
Else
Range("ı" & [ı1000].End(3).Row + 1 & ":" & "m" & [ı1000].End(3).Row + 1).PasteSpecial (xlPasteValues)
End If
End If
Next x
If Cells(4, "h") = "" Then
Cells(3, "h") = "ben"
End If
For y = 1 To [ı1000].End(3).Row - [h1000].End(3).Row
Cells([h1000].End(3).Row + 1, "h") = y
Next y
Cells(3, "h").ClearContents
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub