suzerek verı aktarma

[buseen]

selam ornekte oldugu gıbı verılerı ayrı sayfalara aktarmak ıstıyorum ev sahıbı kıracı dıyerek
bır makro ıle ayırma ve aktarma ıle ılgı acıklayıcı bılgı edınmek ıstıyorum

 

[buseen]

aktarma ısını bır turlu beceremıyorum macro ıle tek takıldım konu yardımcı olan arkadaslara emeklerıne saglık

 

[Orion1]

Dosyanız ekte.

Sub aktar()
Dim sat As Long, i As Long, adr2 As Range
Application.ScreenUpdating = False
For i = 2 To Cells(65536, "B").End(xlUp).Row
    sat = Sheets(Cells(i, "F").Value).Cells(65536, "B").End(xlUp).Row + 1
    If sat >= 65533 Then
        MsgBox "[ " & Cells(i, "F").Value & " ] İsimli sayfada satır doldu Başka kayıt yapılmadı..!!", vbCritical, "UYARI"
        GoTo atla
    End If
        Set adr2 = Sheets(Cells(i, "F").Value).Range(Sheets(Cells(i, "F").Value).Cells(sat, "B") _
        , Sheets(Cells(i, "F").Value).Cells(sat, "E"))
        adr2.Value = Range(Cells(i, "B"), Cells(i, "E")).Value
        Sheets(Cells(i, "F").Value).Cells(sat, "A").Value = sat - 1
atla:
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamam"
End Sub

 

[buseen]

hocam cok saol yalnız aktara tekrar basınca 2 cı defa aynı ısım lerı atıyor.

 

[Orion1]

hocam cok saol yalnız aktara tekrar basınca 2 cı defa aynı ısım lerı atıyor.

Bunu baştan belirtmediğiniz için ben alt alat olacağını kabul etmiştim.
Belirtseydiniz o şekilde hazırlardım.

 

[buseen]

hocam bir bakarmısınız hata varmı
Sub aktar()
Dim sat As Long, i As Long, adr2 As Range
Set SA = Sheets("ev sahibi")
Set SR = Sheets("kiracı")
Application.ScreenUpdating = False
SR.[A1:f100].Delete
SA.[A1:f100].Delete
For i = 2 To Cells(65536, "B").End(xlUp).Row
sat = Sheets(Cells(i, "F").Value).Cells(65536, "B").End(xlUp).Row + 1
If sat >= 65533 Then
MsgBox "[ " & Cells(i, "F").Value & " ] İsimli sayfada satır doldu Başka kayıt yapılmadı..!!", vbCritical, "UYARI"
GoTo atla
End If
Set adr2 = Sheets(Cells(i, "F").Value).Range(Sheets(Cells(i, "F").Value).Cells(sat, "B") _
, Sheets(Cells(i, "F").Value).Cells(sat, "E"))
adr2.Value = Range(Cells(i, "B"), Cells(i, "E")).Value
Sheets(Cells(i, "F").Value).Cells(sat, "A").Value = sat - 1
atla:
Next
Set SA = Sheets("ev sahibi")
Set SR = Sheets("kiracı")

Application.ScreenUpdating = True
MsgBox "İşlem tamam"
End Sub

 

[leumruk]

Ben de hazırlamıştım. Emek boşa gitmesin. Farklı bir yöntem.

Sub Dene()
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("a2:f65536").Clear
Sheets("Sayfa3").Range("a2:f65536").Clear
For i = 2 To [F65536].End(3).Row
If Cells(i, "F") = "Ev Sahibi" Then
Set a = Cells(i, "F")
Set b = Cells(i, "F").Offset(0, -5)
Range(a, b).Copy
Sat = Sheets("Sayfa2").[A65536].End(3).Row + 1
Sheets("Sayfa2").Cells(Sat, "A").PasteSpecial Paste:=xlValue
End If
If Cells(i, "F") = "Kiracı" Then
Set a = Cells(i, "F")
Set b = Cells(i, "F").Offset(0, -5)
Range(a, b).Copy
Sat = Sheets("Sayfa3").[A65536].End(3).Row + 1
Sheets("Sayfa3").Cells(Sat, "A").PasteSpecial Paste:=xlValue
End If
Next i
Application.CutCopyMode = xlCopy
Sheets("Sayfa1").Select
End Sub

 

[buseen]

emeklerınıze saglık

 

[buseen]

sayın leumruk makro ornegı
sayfa 1 baslık nasıl aktaracaz sayfa 2 sayfa 3 e
S / N Ev Sahibinin Adı Soyadı KİRACI ADI SOYADI Blk Daire Durum

 

[Necdet]

Merhaba,

Farklı yöntem kullanmış olayım.

Sub SuzAktar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
s1.Select
s2.Cells.Clear
s3.Cells.Clear
Dim Son As Long
Son = s1.[A65536].End(3).Row
ActiveSheet.Range("A1:F" & Son).AutoFilter Field:=6, Criteria1:="Ev Sahibi"
Range("A:F").SpecialCells(xlCellTypeVisible).Copy s2.[A1]
ActiveSheet.Range("A1:F" & Son).AutoFilter Field:=6, Criteria1:="Kiracı"
Range("A:F").SpecialCells(xlCellTypeVisible).Copy s3.[A1]
Selection.AutoFilter
Application.CutCopyMode = False
End Sub

 

[buseen]

emeklerıne saglık hocam

 

[leumruk]

sayın leumruk makro ornegı
sayfa 1 baslık nasıl aktaracaz sayfa 2 sayfa 3 e
S / N Ev Sahibinin Adı Soyadı KİRACI ADI SOYADI Blk Daire Durum

Sanırım başlıklar sabitti. eğer öyleyse:

Range("a1:f1").Copy Sheets("Sayfa2").Range("a1")
Range("a1:f1").Copy Sheets("Sayfa3").Range("a1")

satırlarını kodlarınızın başına ekleyin. Ama buna da gerek yok. Sonuçta başlıklar sabit. Aynı başlıkları diğer sayfalara da eklerseniz, kod sürekli bu eylemi tekrarlamamış olur.