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

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
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

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
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
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
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

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
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
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
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:

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
Sn. askm, sizin kodu da denedim, sonuç alamadım. Bilginiz olsun.
 

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
Sn. askm koddaki sayfa isimlerinin yerlerini değiştirince sonuç aldım, elinize sağlık. Çok güzel ve faydalı bir kod oldu.
 

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,158
Excel Vers. ve Dili
Ofis 2019 Türkçe
Sub GUNCELLE_TOMSON()
Set deg = Sheets("data_girme")
Set dat = Sheets("PERSONEL")
On Error Resume Next
If Date >= CDate("30/04/2019") Then Exit Sub
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 50
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, "..:: Tomson Tahsin ::.."
End Sub

Sn. Ömer BARAN'a ait yukarıdaki kodlarla sutun başlıklarına göre veri girebiliyorum. Herhangi bir sıkıntı yok.
Ancak ben bu kodun daha da hızlandırılmasını istiyorum, Kodda nasıl bir değişikliğe gidilebilir, girilecek verilerim çok olduğunda bayağı bir beklemeden sonra verileri giriyor.

Bu konuda yardımcı olabilecek arkadaşlarıma şimdiden teşekkür ederim.
Saygılarımla.
 
Üst