aranan sütundan istenilen satırlar çekmek

[tolgafb45]

merhaba arkadaşlar ,

4haftalık tedarik sayfasından w sütununda eksiye düşmüş bakiye satırlarını alacak dene sayfasına atacak.
ama kopyalarken bulduğu hücrenin satırından sadece a,c,d,w hücrelerini atmasını istiyorum.Atarken de w'den gelecek rakamı pozitif hale getirmeli.
aşağıda doğal olarak satırı komple getiriyor nasıl yapcaz onu


Sub deneme()
Dim var As Worksheet
Set var = Sheets("dene")
Set shaf = Sheets("4 Haftalık Tedarik")


Dim bul As Range, satır As Long


Application.ScreenUpdating = False


For Each bul In shaf.Range("w2:w" & shaf.Range("w65536").End(3).Row)

If bul.Value < 0 Then

satır = satır + 1

bul.EntireRow.Copy

var.Select

Cells(satır, 1).PasteSpecial

End If

Next bul

[A1].Select

Application.CutCopyMode = False

Application.ScreenUpdating = True


End Sub

 

[Ömer BARAN]

Merhaba.

Aşağıdaki kod'u kullanabilirsiniz.

Kod, 4 Haftalık Tedarik adlı sayfanın W sütununda NEGATİF değer varsa;
-- A sütundaki hücreyi dene adlı sayfasının A sütununa,
-- B sütundaki hücreyi dene adlı sayfasının B sütununa,
-- D sütundaki hücreyi dene adlı sayfasının C sütununa,
-- W sütunundaki NEGATİF değeri POZİTİF olarak dene adlı sayfanın D sütununa
aktarır.
.

[FONT="Arial Narrow"][B]Sub EKSIYI_ARTI_AKTAR()[/B]
Set h = Sheets("4 Haftalık Tedarik"): Set d = Sheets("dene")
For hsat = 2 To h.[W65536].End(3).Row
    If h.Cells(hsat, 23) < 0 Then
    dsat = d.[A65536].End(3).Row + 1
    d.Cells(dsat, 1) = h.Cells(hsat, 1): d.Cells(dsat, 2) = h.Cells(hsat, 3)
    d.Cells(dsat, 3) = h.Cells(hsat, 4): d.Cells(dsat, 4) = Abs(h.Cells(hsat, 23))
    End If: Next: MsgBox "İşlem Tamamlandı..."
[B]End Sub[/B][/FONT]

 

[vardar07]

Test ediniz.

Sub deneme()
Dim var As Worksheet
Set var = Sheets("dene")
Set shaf = Sheets("4 Haftalık Tedarik")
Dim bul As Range, satır As Long
Application.ScreenUpdating = False
For Each bul In shaf.Range("W2:W" & shaf.Range("W65536").End(3).Row)
a = shaf.Cells(bul.Row, "F").Value
If a < 0 Then
satır = satır + 1
sat = bul.Row
shaf.Range("A" & sat).Copy var.Cells(satır, 1)
shaf.Range("C" & sat).Copy var.Cells(satır, 2)
shaf.Range("d" & sat).Copy var.Cells(satır, 3)
shaf.Range("W" & sat).Copy var.Cells(satır, 4)
var.Cells(satır, 4) = var.Cells(satır, 4) * -1
End If
Next bul
[A1].Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[tolgafb45]

çok teşekkürler tam istediğim gibi olmuş = )

 

[Ömer BARAN]

çok teşekkürler tam istediğim gibi olmuş = )

Merhaba.

Kimin cevabı için söylediğiniz belli değil ama
kendi adıma şunu söyleyeyim; önemli olan ihtiyacın görülmesi elbette.

Kolay gelsin.
.