verilen kritere göre 1 sheet'e 2 sheetten verileri yerleştirme

[majestik_]

merhaba,

Benim sorunum EK'te 2 sayfada bulunan degerleri ilk sayfadaki belirlediğim sutunlara atması ve sayfa 2 de aktarımdan sonra değerlerin kalmaması. acaba olabilirliliği varmıdır. 2 sayfada a sutunundakı deger 1 sayfanın a sutununa b sutunundaki deger 1 sayfanın b sutununa c sutunundaki deger d sutununa d sunundaki deger w sutununa e sutunundakı verı ıse 1 sayfanın u sutununa atması gerek.Şimdiden teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Sub aktar_59()
Dim sat As Long, sh As Worksheet, sat2 As Long
Set sh = Sheets("Sayfa2")
Sheets("FT GENEL DURUM 2012").Select
sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
If sat2 < 2 Then
    MsgBox "Sayfa2'de veri yok." & vbLf & "işlem İptal Oldu!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Exit Sub
End If
If sat >= Rows.Count - 2 Then
    MsgBox "Sayfa Doldu.İşlem Yapılmadı.", vbCritical, "U Y A R I"
    Set sh = Nothing
    Exit Sub
End If
Application.ScreenUpdating = False
sh.Range("A2:B" & sat2).Copy Range("A" & sat)
sh.Range("C2:C" & sat2).Copy Range("D" & sat)
sh.Range("D2:D" & sat2).Copy Range("W" & sat)
sh.Range("E2:E" & sat2).Copy Range("U" & sat)
sh.Range("A2:E" & sat2).ClearContents
sh.Application.CutCopyMode = False
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation

End Sub

 

[majestik_]

dosyanız ektedir.

sub aktar_59()
dim sat as long, sh as worksheet, sat2 as long
set sh = sheets("sayfa2")
sheets("ft genel durum 2012").select
sat = cells(rows.count, "a").end(xlup).row + 1
sat2 = sh.cells(rows.count, "a").end(xlup).row
ıf sat2 < 2 then
    msgbox "sayfa2'de veri yok." & vblf & "işlem iptal oldu!", vbcritical, "u y a r ı"
    set sh = nothing
    exit sub
end ıf
ıf sat >= rows.count - 2 then
    msgbox "sayfa doldu.işlem yapılmadı.", vbcritical, "u y a r ı"
    set sh = nothing
    exit sub
end ıf
application.screenupdating = false
sh.range("a2:b" & sat2).copy range("a" & sat)
sh.range("c2:c" & sat2).copy range("d" & sat)
sh.range("d2:d" & sat2).copy range("w" & sat)
sh.range("e2:e" & sat2).copy range("u" & sat)
sh.range("a2:e" & sat2).clearcontents
sh.application.cutcopymode = false
set sh = nothing
application.screenupdating = true
msgbox "işlem tamamlandı." & vblf & "evrengizlen@hotmail.com", vbokonly + vbınformation

end sub

hocam çok teşekkür ederim emeğinize sağlık

 

[Murat OSMA]

Evren Bey yanıtlamış ama, bu kodlar da kanaatimce yeterlidir;

Sayfa2'de A2'den E50'ye kadar seçin ve formül çubuğunun yanında A2 yazan yere murat yazıp Enter'a basın, sonra Sayfa2'de aşağıdaki makroyu çalıştırın...

[SIZE="2"]Sub Emre()
    Dim i As Integer
    For i = 2 To Range("A65536").End(3).Row
    Cells(i, 1).Copy Sayfa1.Range("A65536").End(3)(2, 1)
    Cells(i, 2).Copy Sayfa1.Range("B65536").End(3)(2, 1)
    Cells(i, 3).Copy Sayfa1.Range("D65536").End(3)(2, 1)
    Cells(i, 4).Copy Sayfa1.Range("W65536").End(3)(2, 1)
    Cells(i, 5).Copy Sayfa1.Range("U65536").End(3)(2, 1)
    Next i: i = Empty: Range("murat").ClearContents
End Sub[/SIZE]

Dosyayı da ekliyorum...

 

[majestik_]

çok saolun fakat ben sızlerı yanlıs yonlendırmısım ekte dosyayı guncelledım a sutunundakı verı b sutununa gecti dogal olarak diğer sutun krıterlerıde değişti acaba gonderdıgınız makrolarda nasıl değişiklik yapmalıyım?

 

[Murat OSMA]

Bu ve buna benzer 5 satır koddaki kırmızı ile belirttiğim sütunları değiştirmelisiniz..

 [SIZE="2"]Cells(i, 1).Copy Sayfa1.Range("[B][COLOR="Red"]A[/COLOR][/B]65536").End(3)(2, 1)[/SIZE]

A sütunu yerine B sütunu - B sütunu yerine C sütunu.. gibi...

 

[majestik_]

Bu ve buna benzer 5 satır koddaki kırmızı ile belirttiğim sütunları değiştirmelisiniz..

 [SIZE="2"]Cells(i, 1).Copy Sayfa1.Range("[B][COLOR="Red"]A[/COLOR][/B]65536").End(3)(2, 1)[/SIZE]

A sütunu yerine B sütunu - B sütunu yerine C sütunu.. gibi...

hocam cok tesekkur ederım aslında evren beyin gonderdiği kodlar uzerinde soyledıgınızı denedım ama pek basarılı olamadım aynı veriyi birden fazla yere attı sızın kodlarda sansımı deneyeyım cok saolun

 

[Orion1]

çok saolun fakat ben sızlerı yanlıs yonlendırmısım ekte dosyayı guncelledım a sutunundakı verı b sutununa gecti dogal olarak diğer sutun krıterlerıde değişti acaba gonderdıgınız makrolarda nasıl değişiklik yapmalıyım?

Dosyanız ektedir.

Sub aktar_59()
Dim sat As Long, sh As Worksheet, sat2 As Long
Set sh = Sheets("Sayfa2")
Sheets("FT GENEL DURUM 2012").Select
sat = Cells(Rows.Count, "B").End(xlUp).Row + 1
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
If sat2 < 2 Then
    MsgBox "Sayfa2'de veri yok." & vbLf & "işlem İptal Oldu!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Exit Sub
End If
If sat >= Rows.Count - 2 Then
    MsgBox "Sayfa Doldu.İşlem Yapılmadı.", vbCritical, "U Y A R I"
    Set sh = Nothing
    Exit Sub
End If
Application.ScreenUpdating = False
sh.Range("A2:B" & sat2).Copy Range("B" & sat)
sh.Range("C2:C" & sat2).Copy Range("E" & sat)
sh.Range("D2:D" & sat2).Copy Range("X" & sat)
sh.Range("E2:E" & sat2).Copy Range("V" & sat)
sh.Range("A2:E" & sat2).ClearContents
sh.Application.CutCopyMode = False
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation

End Sub

 

[ticubukcu]

Liste Oluşturma

Merhabalar;

ekte göderdiğim dosyada bir sayfada demirbaş listesi ve karşısında da adetleri; ve sütunlarda da oda isimleri var. 2. sayfa istenilen odaya ait liste oluşturula bilir mi? yardımcı olabilirmisiniz. teşekür ederim. mail adresim
(ticubukcu@hotmail.com)