veri aktarma hakkında

[hurkanpisirici]

merhaba sitede bir çok örneği var ama kendime uyarlayamadım ekli dosyada istediğimi belirttim çek listemi ilgili sayfalarına aktarmak istiyorum.şimdide teşekkürler.

 

[Orion1]

Dosyanız ekte.

Sub cek_aktar()
Dim sat As Long, hcr_banka As String, syf_banka As String, syf As Worksheet
Sheets("PORTFÖY").Select
Application.ScreenUpdating = False
For i = Cells(65536, "B").End(xlUp).Row To 2 Step -1
    hcr_banka = UCase(Replace(Replace(Cells(i, "D").Value, "ı", "I"), "i", "İ"))
    If hcr_banka = "PORTFÖY" Then GoTo atla
    For Each syf In Worksheets
        If hcr_banka = UCase(Replace(Replace(syf.Name, "ı", "I"), "i", "İ")) Then
            son = syf.Cells(65536, "B").End(xlUp).Row + 1
            If son >= 65533 Then
                MsgBox "[ " & syf.Name & " ] Satır doldu..!!" & _
                vbLf & "Bu sayfaya kayıt yapılmadı..!!", vbCritical, "UYARI"
                GoTo atla
            End If
            syf.Range(syf.Cells(son, "A"), syf.Cells(son, "D")).Value = _
            Range(Cells(i, "A"), Cells(i, "D")).Value
            Range(Cells(i, "A"), Cells(i, "D")).Delete (xlUp)
            GoTo atla
        End If
    Next syf
        MsgBox "[ " & hcr_banka & " Sayfası bulunmadı..!!" & vbLf & _
        "Girilmeyen kayıt adresi : " & Range("D" & i).Address & _
        vbLf & "Sayfa Adı : " & hcr_banka
atla:
Next i
Application.ScreenUpdating = True
MsgBox "Aktarma işlemi tamamlandı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[hurkanpisirici]

hocam çok teşerkkür ederim ilginiz için ama portföy sayfasında veriler kalıyor.yani aktar dediğimde sadece portföy yazan lar kalmalı? çok özür dilerim

 

[Orion1]

hocam çok teşerkkür ederim ilginiz için ama portföy sayfasında veriler kalıyor.yani aktar dediğimde sadece portföy yazan lar kalmalı? çok özür dilerim

Aktarılanlar silinecekmi?

 

[Ayhan Ercan]

Merhaba

Alternatik olarak....

Sub Düğme1_Tıklat()
Dim son As Long, i As Integer, j As Integer
son = [d65536].End(3).Row
    For i = 2 To son
        For j = 2 To Sheets.Count
            If Cells(i, "D") = Sheets(j).Name Then
                Range("A" & i & ":D" & i).Cut _
                Sheets(j).Range("a" & Sheets(j).[a65536].End(3).Row + 1)
            End If
        Next j
    Next i
End Sub

 

[hurkanpisirici]

evet evren hocam

 

[hurkanpisirici]

ayhan hocam sizede çok teşekkür edeirm sağolun

 

[Orion1]

hocam çok teşerkkür ederim ilginiz için ama portföy sayfasında veriler kalıyor.yani aktar dediğimde sadece portföy yazan lar kalmalı? çok özür dilerim

Dosyayı düzenledim.
2 numaralı mesajdan indirebilirsiniz.

 

[hurkanpisirici]

hocam ne desem az gelir çok teşekkürler.

bu arada hücreleri genişletmek istersem

Range(Cells(i, "A"), Cells(i, "D")).Value
Range(Cells(i, "A"), Cells(i, "D")).Delete (xlUp)


bu satırlardan yapacağım dimi

 

[Ayhan Ercan]

hocam ne desem az gelir çok teşekkürler.

bu arada hücreleri genişletmek istersem

Range(Cells(i, "A"), Cells(i, "D")).Value
Range(Cells(i, "A"), Cells(i, "D")).Delete (xlUp)


bu satırlardan yapacağım dimi

Sayın Evren Hocam Harikulade bir örnek kod hazırlamış, ellerine sağlık..

Evet o satırlardan yapacaksınız.. "A" ve "D" leri istediğiniz kadar daraltıp genişletebilirsiniz..

 

[hurkanpisirici]

maaşım artarsa ikiniz sayesinde olacak zaten çok iyisiniz çok teşeklkür edeirm

 

[Ayhan Ercan]

maaşım artarsa ikiniz sayesinde olacak zaten çok iyisiniz çok teşeklkür edeirm

Maaşın artsın yeterki, yardımımız dokunsun önemli değil...

 

[hurkanpisirici]

Dualarımı alıyorsunuz Allah inşallah gönlünüze göre nasip eder herşeyi kolay gelsin