• FORUMU MOBİL UYGULAMADAN TAKİP EDİN

    Forumu isteyen üyelerimiz Tapatalk (Harici bir hizmet) üzerinden mobil uygulamadan takip edebilirler.
    iOS için : https://itunes.apple.com/app/id307880732?mt=8
    Android için : https://play.google.com/store/apps/details?id=com.quoord.tapatalkpro.activity
    adreslerinden indirebilirsiniz.

    Bir iki haftaya da foruma özel kendi uygulamamız yayında olacak.
ALTIN ÜYELİK Hakkında Bilgi
-----------------------

Sutun başlığına göre sayfaya veri gönderme

tahsinanarat

Altın Üye
Altın Üye
Katılım
14 Mart 2005
Mesajlar
1,818
Beğeniler
1
Excel Vers. ve Dili
Ofis 2016 Türkçe
#1
Ekli dosyamda izah etmeye çalıştım, Bir database sayfam var, bu sayfam yaklaşık 40 sutun başlığından ibaret olup, zaman zaman bu sütunlara bilgi
transfer etmem gerekiyor. Bilgi göndereceğim sutuna sicilini yazdığım kişilerle kesişen hücrelere yazdığım bilgiler kaydedilecek, diğer satırlarda herhangi
bir değişiklik olmayacak. Örnek dosyamda sarı ile işaretli hücrelere göndereceğim verilerin makro ile yerleştirilmesini istiyorum, yardımca olacak arkadaşlarıma şimdiden
teşekkür edirim.
Saygılarımla.
 

Ekli dosyalar

Katılım
8 Mart 2011
Mesajlar
12,052
Beğeniler
340
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
#2
Merhaba.

İki sayfadaki sütun adları birebir aynı olmak koşuluyla aşağıdaki kod işinizi görecektir.
degisecekler sayfasında birinci satırdaki başlıklara göre (A1:H1 arası için DOLU/BOŞ kontrolü var) başlık satırı dolu olan
satırlardaki veriler yerlerine aktırılır.
(kastım, degisecekler isimli sayfada kullanılan sütun başlıklarının, aynı sırada olması olmasa da birebir aynı olmasıdır)
Rich (BB code):
Sub GUNCELLE_BRN()
Set deg = Sheets("degisecekler")
Set dat = Sheets("Database")
    For sat = 2 To deg.Cells(Rows.Count, "A").End(3).Row
        Set dsa = dat.[A:A].Find(deg.Cells(sat, 1))
        If Not dsa Is Nothing Then
            For sut = 2 To 40
                If deg.Cells(1, sut) <> "" Then
                    Set dsu = dat.[1:1].Find(deg.Cells(1, sut))
                    If Not dsu Is Nothing Then
                        If deg.Cells(sat, sut) <> "" Then _
                            dat.Cells(dsa.Row, dsu.Column) = deg.Cells(sat, sut)
                    End If
                End If
            Next
        End If
    Next
deg.Range("A2:H" & deg.Cells(Rows.Count, "A").End(3).Row).ClearContents
MsgBox "Veriler ilgili alanlara aktarıldı...", vbInformation, "..:: Ömer BARAN ::.."
End Sub
 
Son düzenleme:

tahsinanarat

Altın Üye
Altın Üye
Katılım
14 Mart 2005
Mesajlar
1,818
Beğeniler
1
Excel Vers. ve Dili
Ofis 2016 Türkçe
#3
Sn. Ömer BARAN hocam, öncelikle hızlı cevabınız için çok teşekkür ederim, çok değerli bir kod, umarım herkesin işine yarayan bir kod olur, elinize sağılık, saygılarımla.
 

askm

Altın Üye
Altın Üye
Katılım
4 Haziran 2005
Mesajlar
2,420
Beğeniler
38
Excel Vers. ve Dili
2010-2016
#4
Alternatif olsun.
Kod:
Sub Düğme1_Tıkla()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("degisecekler")
Set s2 = Sheets("Database")
Application.ScreenUpdating = False
On Error Resume Next
son2 = s2.Range("A" & Rows.Count).End(3).Row
Sonstn1 = s1.Cells(1, Columns.Count).End(xlToLeft).Column
sonstn2 = s2.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To s1.Range("A" & Rows.Count).End(3).Row
    satir = s2.Range("A2:A" & son2).Find(s1.Cells(i, 1)).Row
    For y = 2 To Sonstn1
        sutun = s2.Range(s2.Cells(1, 2), s2.Cells(1, sonstn2)).Find(s1.Cells(1, y)).Column
        s1.Cells(i, y).Value = s2.Cells(satir, sutun).Value
    Next y
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub
 

tahsinanarat

Altın Üye
Altın Üye
Katılım
14 Mart 2005
Mesajlar
1,818
Beğeniler
1
Excel Vers. ve Dili
Ofis 2016 Türkçe
#5
Database sayfasında sutun başlıkları 2.satırda başladığı için aşağıdaki şekilde denedim, oldu. Teşekkürler hocam
Sub GUNCELLE_BRN()
Set deg = Sheets("degisecekler")
Set dat = Sheets("Database")
For sat = 2 To deg.Cells(Rows.Count, "A").End(3).Row
Set dsa = dat.[A:A].Find(deg.Cells(sat, 1))
If Not dsa Is Nothing Then
For sut = 2 To 40
If deg.Cells(1, sut) <> "" Then
Set dsu = dat.[2:2].Find(deg.Cells(1, sut))
If Not dsu Is Nothing Then
If deg.Cells(sat, sut) <> "" Then _
dat.Cells(dsa.Row, dsu.Column) = deg.Cells(sat, sut)
End If
End If
Next
End If
Next
'deg.Range("A2:H" & deg.Cells(Rows.Count, "A").End(3).Row).ClearContents
MsgBox "Veriler ilgili alanlara aktarıldı...", vbInformation, "..:: Ömer BARAN ::.."
End Sub
 
Son düzenleme:
Katılım
8 Mart 2011
Mesajlar
12,052
Beğeniler
340
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
#8
Sn. Ömer BARAN hocam, öncelikle hızlı cevabınız için çok teşekkür ederim, çok değerli bir kod, umarım herkesin işine yarayan bir kod olur, elinize sağılık, saygılarımla.
Eyvallah.
Önemli olan ihtiyacın görülmesi.
.
 
Üst