• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Sayfalar arası veri tansferi ve kitaplar arası veri transferi

O

onurcan1979

Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
İyi akşamlar benim ikitane sorunumvar biri sayfalar arası veri transferi biride kitaplar arası veri transferi formu inceledim çok güzel çalışmalarvar özellikle İhsan Tank beyin sayfalar arası veri transferi gerçektende çok güzel bir çalışma fakat ben G1 hücresine gireceğim verinin süzülüp transfer edilmesini istiyorum aynı işlemi kitaplar arasındada yapmak istiyorum

ilhan beyin yapmış olduğu makro ile veri aktarımına benzer

örnek
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

ve birbaşka üstadın yaptığı çalışmada olduğu gibi hücre içinden süzerek veri aktarımını yapmak istiyorum

örnek
On Error Resume Next
If Intersect(Target, [g1]) Is Nothing Then Exit SubApplication.ScreenUpdating = False
Set s1 = Sheets("SERVİSE.GİDEN")
Range("A8:M65536").ClearContents
Set Aralik = s1.Range("A2:A" & s1.[A65536].End(3).Row)
Set Bul = Aralik.Find(Target.Text, LookAt:=xlWhole)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
sat = [A65536].End(3).Row + 1
s1.Range(s1.Cells(Bul.Row, "A"), s1.Cells(Bul.Row, "M")).Copy
Cells(sat, "A").PasteSpecial Paste:=xlValues
Set Bul = Aralik.FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> Adres
Application.CutCopyMode = False
MsgBox "DİSİPLİN İşlem tamam.", vbInformation, "RAPOR DURUMU"
End If

sadece ilhan beyin yaptığı gibi aktarılmasını istediğim sütunlardaki bilgileri ayarlamayı yapabilmek istiyorum bana bu konuda yardımcı olursanız çok sevinirim

not. ana klasör kaynak kitap
 

Ekli dosyalar

Günaydın

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

arkadaşlar yukarda bulunan kodu m1 hücresine yazacağım veriyi süzerek yapmasını istiyorum bunu nasıl yapa bilirim bana bu konuda yardımcı olurmusunuz?
 
If Cells(ts, "M") = "OK" Then
Satırı
If Cells(ts, "M") = [Sayfaismi!G1] Then
Şeklinde değiştirin.
G1 e yazacağın veriyi koşula eklemelisin.
 
Mustafa MUTLU' Alıntı:
If Cells(ts, "M") = "OK" Then
Satırı
If Cells(ts, "M") = [Sayfaismi!G1] Then
Şeklinde değiştirin.
G1 e yazacağın veriyi koşula eklemelisin.
Genişletmek için tıkla ...

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("E2:E65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 2
For ts = 2 To Cells(65536, "E").End(xlUp).Row
If Cells(ts, "E") = [İSTİFALAR!E1] Then
Sheets("MERSİN").Cells(kaplan, "A") = Sheets("İSTİFALAR").Cells(ts, "A")
Sheets("MERSİN").Cells(kaplan, "B") = Sheets("İSTİFALAR").Cells(ts, "B")
Sheets("MERSİN").Cells(kaplan, "C") = Sheets("İSTİFALAR").Cells(ts, "C")
Sheets("MERSİN").Cells(kaplan, "D") = Sheets("İSTİFALAR").Cells(ts, "D")
Sheets("MERSİN").Cells(kaplan, "E") = Sheets("İSTİFALAR").Cells(ts, "E")
Sheets("MERSİN").Cells(kaplan, "F") = Sheets("İSTİFALAR").Cells(ts, "F")
Sheets("MERSİN").Cells(kaplan, "G") = Sheets("İSTİFALAR").Cells(ts, "G")
Sheets("MERSİN").Cells(kaplan, "H") = Sheets("İSTİFALAR").Cells(ts, "H")
Sheets("MERSİN").Cells(kaplan, "I") = Sheets("İSTİFALAR").Cells(ts, "I")
Sheets("MERSİN").Cells(kaplan, "J") = Sheets("İSTİFALAR").Cells(ts, "J")
Sheets("MERSİN").Cells(kaplan, "K") = Sheets("İSTİFALAR").Cells(ts, "K")
Sheets("MERSİN").Cells(kaplan, "L") = Sheets("İSTİFALAR").Cells(ts, "L")
Sheets("MERSİN").Cells(kaplan, "M") = Sheets("İSTİFALAR").Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

Bu şekilde yaptım ama olmadı
 
onurcan1979' Alıntı:
İyi akşamlar
Genişletmek için tıkla ...

Şunu Denermisiniz
ANA KLASÖR E

Sub MUSTAFA()
Dim MM, MSTF, Mustafa_MUTLU1
Mustafa_MUTLU1 = Sheets("Sayfa2").Range("G1")
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("A2:P65536").ClearContents
MM = 2
For MSTF = 2 To Sheets("Sayfa1").Cells(65536, "A").End(xlUp).Row
If Sheets("Sayfa1").Cells(MSTF, "B") = Mustafa_MUTLU1 Then
Sheets("Sayfa2").Cells(MM, "A") = Sheets("Sayfa1").Cells(MSTF, "A")
Sheets("Sayfa2").Cells(MM, "B") = Sheets("Sayfa1").Cells(MSTF, "B")
Sheets("Sayfa2").Cells(MM, "C") = Sheets("Sayfa1").Cells(MSTF, "C")
Sheets("Sayfa2").Cells(MM, "D") = Sheets("Sayfa1").Cells(MSTF, "D")
Sheets("Sayfa2").Cells(MM, "E") = Sheets("Sayfa1").Cells(MSTF, "E")
Sheets("Sayfa2").Cells(MM, "F") = Sheets("Sayfa1").Cells(MSTF, "F")
Sheets("Sayfa2").Cells(MM, "G") = Sheets("Sayfa1").Cells(MSTF, "G")
Sheets("Sayfa2").Cells(MM, "H") = Sheets("Sayfa1").Cells(MSTF, "H")
Sheets("Sayfa2").Cells(MM, "I") = Sheets("Sayfa1").Cells(MSTF, "I")
Sheets("Sayfa2").Cells(MM, "J") = Sheets("Sayfa1").Cells(MSTF, "J")
Sheets("Sayfa2").Cells(MM, "K") = Sheets("Sayfa1").Cells(MSTF, "K")
Sheets("Sayfa2").Cells(MM, "L") = Sheets("Sayfa1").Cells(MSTF, "L")
Sheets("Sayfa2").Cells(MM, "M") = Sheets("Sayfa1").Cells(MSTF, "M")
Sheets("Sayfa2").Cells(MM, "N") = Sheets("Sayfa1").Cells(MSTF, "N")
Sheets("Sayfa2").Cells(MM, "O") = Sheets("Sayfa1").Cells(MSTF, "O")
Sheets("Sayfa2").Cells(MM, "P") = Sheets("Sayfa1").Cells(MSTF, "P")
MM = MM + 1
End If
Next
Application.ScreenUpdating = True
MsgBox Mustafa_MUTLU1 & " Görevlerini Aktardım", vbInformation, "MUSTAFA MUTLU"
End Sub
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst