• DİKKAT

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

Aynı kitap içinde. Sayfadan sayfaya veri aktarımı.

  • Konbuyu başlatan Konbuyu başlatan Bora K
  • Başlangıç tarihi Başlangıç tarihi
B

Bora K

Katılım
21 Ocak 2013
Mesajlar
331
Excel Vers. ve Dili
2003 Türkçe
Merhabalar.

Değerli arkadaşlar.
Aynı kitap içerisinde sayfadan sayfaya veri aktarmak için
makro koduna ihtiyacım var. İstediğim koda benzer kodlarım var
lakin kendim revize edemedim. Yardımlarınızı bekliyorum. Lütfen.

Örnek dosyadaki açıklamam şu şekilde:
C2 ve E2 hücrelerindeki veriler.
"Data" adlı sayfanın D ve F sütununda
xxx yyy ve yyy xxx şeklinde aranacak. Bulunduğu takdirde
ilgili satırın "N" hücresi kontrol edilecek. "N" hücresi
boş ise eğer ilgili veriler Bu sayfaya yanda görüldüğü
şekilde 5. satırdan itibaren İLK BOŞ satıra yazılacak.
Bu sayfaya aktarılan satırlar "Data" sayfasında "N" hücresinde "ok" yazılarak işaretlenecek.

NOT: Bu sayfa yani makroyu tetikleyeceğimiz sayfanın
adı makroda geçmemesi gerekiyor
 

Ekli dosyalar

Son düzenleme:
Merhaba
Boş bir module kopyalayın ve deneyin.
Kod: 
Option Explicit
Sub veri_al()
Dim S1 As Worksheet, STR As Long, VR As Long, SBT As Variant
Dim ARA1 As Variant, ARA2 As Variant, BUL As Range
Set S1 = Sheets("Data")
STR = Range("H" & Rows.Count).End(xlUp).Row + 1
If STR < 5 Then STR = 5
For VR = 1 To 2
If VR = 1 Then
ARA1 = Range("C2"): ARA2 = Range("E2")
Else
ARA1 = Range("E2"): ARA2 = Range("C2")
End If
Set BUL = S1.Range("D:D").Find(ARA1, , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
If S1.Cells(BUL.Row, "F") = ARA2 And S1.Cells(BUL.Row, "H") <> Empty _
And S1.Cells(BUL.Row, "N") = Empty Then
Cells(STR, "H") = S1.Cells(BUL.Row, "B"): Cells(STR, "I") = S1.Cells(BUL.Row, "C")
Cells(STR, "J") = S1.Cells(BUL.Row, "E"): Cells(STR, "K") = S1.Cells(BUL.Row, "D")
Cells(STR, "L") = S1.Cells(BUL.Row, "H"): Cells(STR, "M") = S1.Cells(BUL.Row, "I")
Cells(STR, "N") = S1.Cells(BUL.Row, "J"): Cells(STR, "O") = S1.Cells(BUL.Row, "K")
Cells(STR, "P") = S1.Cells(BUL.Row, "L"): Cells(STR, "Q") = S1.Cells(BUL.Row, "F")
Cells(STR, "R") = S1.Cells(BUL.Row, "F"): S1.Cells(BUL.Row, "N") = "Ok"
STR = STR + 1
End If
Set BUL = S1.Range("D:D").FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Next
End Sub
 
Son düzenleme:
Merhaba sayın Asi Kral.
Çok özür dilerim küçük bir ilave gerekli
Eki yeniden güncelledim bakabilirseniz çok sevinirim.
 
Sayın Asi Kral Kırmızı ile belirttiğim şart ilave edilecek.

C2 ve E2 hücrelerindeki veriler.
Data adlı sayfanın D ve F sütununda
xxx yyy ve yyy xxx şeklinde aranacak. Bulunduğu takdirde
ilgili satırın "H" hücresi kontrol edilecek eğer "H" hücresi boş ise o satır atlanacak.
"H" hücresi dolu ise ilgili satırın "N" hücresi kontrol edilecek. "N" hücresi
boş ise eğer ilgili veriler Bu sayfaya yanda görüldüğü
şekilde 5. satırdan itibaren İLK BOŞ satıra yazılacak.
Bu sayfaya aktarılan satırlar "Data" sayfasında "N" hücresinde "ok" yazılarak işaretlenecek.

NOT: Bu sayfa yani makroyu tetikleyeceğimiz sayfanın
adı makroda geçmemesi gerekiyor.
 
Bora K' Alıntı:
Sayın Asi Kral Kırmızı ile belirttiğim şart ilave edilecek.

C2 ve E2 hücrelerindeki veriler.
Data adlı sayfanın D ve F sütununda
xxx yyy ve yyy xxx şeklinde aranacak. Bulunduğu takdirde
ilgili satırın "H" hücresi kontrol edilecek eğer "H" hücresi boş ise o satır atlanacak.
"H" hücresi dolu ise ilgili satırın "N" hücresi kontrol edilecek. "N" hücresi
boş ise eğer ilgili veriler Bu sayfaya yanda görüldüğü
şekilde 5. satırdan itibaren İLK BOŞ satıra yazılacak.
Bu sayfaya aktarılan satırlar "Data" sayfasında "N" hücresinde "ok" yazılarak işaretlenecek.

NOT: Bu sayfa yani makroyu tetikleyeceğimiz sayfanın
adı makroda geçmemesi gerekiyor.
Genişletmek için tıkla ...

Kod güncellemesi yapıldı.
Makro istediğiniz sorularınızın hepsini aynı anda sorun makro formül gibi bir yeri değiştiğinde çalışan bir şey değil tekrardan yazmak zorunda bırakırsınız karşınızdakileri bu da hiç hoş değil bir daha ki seferinde yardım alamazsınız bilginiz olsun.
 
Yardımlarınız için çok teşekkür ederim.
Sayın Asi Kral. Ellerinize zihninize sağlık.
İlave içinde tekrardan özür dilerim.
Dalgınlığıma denk geldi.

Herşey gönlünüzce olsun inşallah.
Saygılar.
 
Bora K' Alıntı:
Yardımlarınız için çok teşekkür ederim.
Sayın Asi Kral. Ellerinize zihninize sağlık.
İlave içinde tekrardan özür dilerim.
Dalgınlığıma denk geldi.

Herşey gönlünüzce olsun inşallah.
Saygılar.
Genişletmek için tıkla ...

Kolay Gelsin.
 
Merhabalar
Asi Kral.

Küçük bir sorunumuz var kodda sonradan farkedebildim bende.
Örnek dosyada izah ettim. Bakabilirmisiniz lütfen.
 

Ekli dosyalar

Doğru öncelikle xxxleri buluyor sonra yyy'leri buluyor.
 
Kod bu hali ile işlevini yapamıyor maalesef.
Ne yapmamız lazım peki bu durumda..
Bi çözüm üretemezmiyiz?
 
Bora K' Alıntı:
Kod bu hali ile işlevini yapamıyor maalesef.
Ne yapmamız lazım peki bu durumda..
Bi çözüm üretemezmiyiz?
Genişletmek için tıkla ...

siz tam olarak ne istiyorsunuz. Dosya üzerinde ayrıntılı hücre adreslerini bildirerek gönderirseniz bakayım. Bu şekilde bir şey yapamam.
 
Merhaba,

Her yeni aktarımdan sonra deneme sayfasındaki veriler silenecek mi, yoksa altından yazmaya devam mı edecek?
 
Merhaba Ömer Bey.

Altından yazmaya devam edecek.
 
Bora K' Alıntı:
Merhaba Ömer Bey.

Altından yazmaya devam edecek.
Genişletmek için tıkla ...

Bu şekilde deneyin.

Kod: 
Sub BulAktar()
 
    Dim Sd As Worksheet, sat As Long, sut As Byte, c As Range, Adr As String
 
    Set Sd = Sheets("Data")
 
    Application.ScreenUpdating = False
    sat = Cells(Rows.Count, "K").End(xlUp).Row + 1
    If Range("K5") = "" Then sat = 5
 
    With Sd.Range("D:D,F:F")
        Set c = .Find(Range("C2"), , xlValues, xlWhole)
        If Not c Is Nothing Then
             Adr = c.Address
             Do
                sut = 4
                If c.Column = 4 Then sut = 6
                If Sd.Cells(c.Row, "N") = "" Then
                    If Sd.Cells(c.Row, sut) = Range("E2") Then
                       Sd.Range("B" & c.Row, "C" & c.Row).Copy Cells(sat, "H")
                       Cells(sat, "J") = Sd.Cells(c.Row, "E")
                       Cells(sat, "K") = Sd.Cells(c.Row, "D")
                       Sd.Range("H" & c.Row, "L" & c.Row).Copy Cells(sat, "L")
                       Cells(sat, "Q") = Sd.Cells(c.Row, "F")
                       Sd.Cells(c.Row, "N") = "Ok"
                       sat = sat + 1
                    End If
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
    Application.ScreenUpdating = True
 
End Sub

.
 
Merhabalar

Ömer Bey. Sizin yazdığınız kodda da Asi kralın kodundaki hata
var.

c2 ve e2 ye xxx yyy değerlerini giriyoruz.
lakin aramayı hem xxx yyy şeklinde hemde yyy xxx şeklinde yapıyoruz.
mevcut kodlar
ilk önce xxx yyy leri getiriyor
sonra yyy xxx leri getiyor.
Yani satır sıraları dikkate alınmıyor. (7. satırdan 11 satıra atlanıyor gibi)

örnektir.
Data sayfamızda verilerimiz bu şekilde iken
1. satır xxx yyy
2. satır yyy xxx
3. satır xxx yyy
4. satır yyy xxx

Üstteki veriler Deneme sayfasına
1. satır xxx yyy
3. satır xxx yyy
2. satır yyy xxx
4. satır yyy xxx
bu şekilde geliyor.
satırlara dikkat edilirse yer değiştiriyor.
Bunun olmamamıs lazım.

Özetle : Data sayfasındaki veriler birebir Deneme sayfasına aktarılacak. (Satır sırası değişmeden)
Aktarma yapılırken sadece bazı sütunlar yer değiştiriyor.
Herşeye rağmen. Sizin kod ile örnek dosya ekledim. olması gerekeni mevcut
verinin altında gösterdim.
 

Ekli dosyalar

  • EK.xls
    EK.xls
    32.5 KB · Görüntüleme: 10
Aktarım sırasındaki önemi farketmemişim.

Bu şekilde deneyin.

Kod: 
Sub BulAktar()
 
    Dim Sd As Worksheet, sat As Long, sut As Byte, c As Range, Adr As String
 
    Set Sd = Sheets("Data")
 
    Application.ScreenUpdating = False
    sat = Cells(Rows.Count, "K").End(xlUp).Row + 1
    If Range("K5") = "" Then sat = 5
 
    With Sd.Range("D:F")
        Set c = .Find(Range("C2"), , xlValues, xlWhole)
        If Not c Is Nothing Then
             Adr = c.Address
             Do
                If c.Column <> 5 Then
                    sut = 4
                    If c.Column = 4 Then sut = 6
                    If Sd.Cells(c.Row, "N") = "" Then
                        If Sd.Cells(c.Row, sut) = Range("E2") Then
                           Sd.Range("B" & c.Row, "C" & c.Row).Copy Cells(sat, "H")
                           Cells(sat, "J") = Sd.Cells(c.Row, "E")
                           Cells(sat, "K") = Sd.Cells(c.Row, "D")
                           Sd.Range("H" & c.Row, "L" & c.Row).Copy Cells(sat, "L")
                           Cells(sat, "Q") = Sd.Cells(c.Row, "F")
                           Sd.Cells(c.Row, "N") = "Ok"
                           sat = sat + 1
                        End If
                    End If
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
    Application.ScreenUpdating = True
 
End Sub

.
 
Ömer Bey

"Data" sayfasında aktarılacak satırların "H" hücresi boş ise
şayet ilgili satır atlanacak (aktarılmayacak)

Buna ek olarak veriler değer olarak aktarılacak.
Bu ilaveleri yapabilirmisiniz lütfen. Teşekkür ederim.
 
Bu şekilde deneyin.

Kod: 
Sub BulAktar()
 
    Dim Sd As Worksheet, sat As Long, sut As Byte, c As Range, Adr As String
 
    Set Sd = Sheets("Data")
 
    Application.ScreenUpdating = False
    sat = Cells(Rows.Count, "K").End(xlUp).Row + 1
    If Range("K5") = "" Then sat = 5
 
    With Sd.Range("D:D,F:F")
        Set c = .Find(Range("C2"), , xlValues, xlWhole)
        If Not c Is Nothing Then
             Adr = c.Address
             Do
                sut = 4
                If c.Column = 4 Then sut = 6
                If Sd.Cells(c.Row, "N") = "" And Sd.Cells(c.Row, "H") <> "" Then
                    If Sd.Cells(c.Row, sut) = Range("E2") Then
                       Sd.Range("B" & c.Row, "C" & c.Row).Copy
                       Cells(sat, "H").PasteSpecial Paste:=xlPasteValues
                       Cells(sat, "J") = Sd.Cells(c.Row, "E")
                       Cells(sat, "K") = Sd.Cells(c.Row, "D")
                       Sd.Range("H" & c.Row, "L" & c.Row).Copy
                       Cells(sat, "L").PasteSpecial Paste:=xlPasteValues
                       Cells(sat, "Q") = Sd.Cells(c.Row, "F")
                       Sd.Cells(c.Row, "N") = "Ok"
                       sat = sat + 1
                    End If
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    
    Range("C2").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
 
End Sub

.
 
Merhaba Ömer Bey.
H hücresi boş ise aktarma olmuyor. ok
Veriler değer olarak geliyor. ok

Lakin satır sorunu tekrar başladı.
16. mesajdaki yazdıklarım yine geçerli
Kendim birşeyler yapmaya çalışıyorum emmevelakin
beceremiyorum.:(
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst