Hücredeki Veriye Göre Başka Sayfadan Satır Kopyalamak

[vurkan]

Arkadaşlar Merhaba. KULÜP LİSTESİ sayfasında D sütununa Okul no yazıp Enter tuşuna basınca o numarayı VERİ sayfasında C sütununda bulup o satırı A aralığında Kopyalayıp KULÜP LİSTESİ sayfasında B:Q aralığına yapıştırmak istiyorum. Bunu Düşeyara ile yapabiliyorum. Ancak yazılan formüller dosyayı yavaşlatmasın diye kod ile yapmak istiyorum.

A sütununa seçim kutuları eklemek istediğimden o sütun oş kalmalı. Buraya satır doldukça kutu (veya benzeri birşey) otomatik eklenirse güzel olur. Daha sonra o seçili satırları TC. Kimlik Noya göre yazıcıya göndermeyi planlıyorum. Bu konuda da yardımcı olabilirseniz sevinirim. Saygılar.

http://s3.dosya.tc/server17/5wgzdc/SATIR_KOPYALAMA.rar.html

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Link:
http://dosya.co/ef33mununkyp/vurkan-SATIR_KOPYALAMA.zip.html

 

[vurkan]

Sayın muygun Üstadım. Kodları gerçek dosyama uygulayacağım. Bir ilave mümkün mü acaba. Kulüp listesi sayfasında çift tıklama ile tc noların gelmesi çok güzel olmuş. Buna bir de mesela tümünü seçmek için A1 veya başka bir yere çift tıklayınca tüm dolu satırların TC leri gelse çok hoş olurdu. Tekrar çift tıklatınca tüm seçim kaldırılırdı. Böylece tümünü yazdırmak daha kolay olurdu. Bunun için nasıl bir ekleme yapabilirim.Teşekkür ediyorum.

 

[muygun]

Merhaba;
Sayfanın kod bölümüne;

Sub hepsini_seç()
For i = 3 To Range("d65536").End(xlUp).Row
If Cells(i, "b") <> "" Then
Cells(i, 1) = Cells(i, "j")
Cells(i, 1).Interior.ColorIndex = 4
End If
Next i
End Sub

Sub seçimleri_temizle()
For i = 3 To Range("A65536").End(xlUp).Row
Cells(i, 1) = ""
Cells(i, 1).Interior.ColorIndex = xlNone
Next i
End Sub

Kodlarını yerleştirerek birer butona bağlayın.

İyi çalışmalar.

 

[canergkts]

Teşekkürler arkadaşlar.

 

[vurkan]

Sayın muygun Üstadım. Sizin ve Sayın Ömer Baran Üstadımın yardımlarıyla dosyamı tamamladım. Rabbim emeği geçen tüm arkadaşlardan razı olsun.
Yalnız bir nokta içime sinmedi. O da dosyaları birleştirme kodlarımızdaki S1 hücresine yazılan birleştirilecek dosyalar için yol yazmak. Ben bunu yapabiliyorum. Ancak bu dosyayı başka bilgisayarlarda kullanacak arkadaşlar bunu ne kadar başarır bilemiyorum. Bu kodları S1 hücresine yol yazmak yerine ÖGRENCİ LİSANS PROGRAMI isimli çalışma kitabımızın olduğu klasörde e okuldan aktarılan sınıf bilgileri toplansa ve makro çalıştırılınca direk çalışma kitabının içinde bulunduğu klasörden sınıfları alıp birleştirme yapsa daha kullanışlı olur diye düşünüyorum. Bu şekilde kodlar düzenleyebilirsek çok yararlı olacaktır. Sizin yazdığınız aşağıdaki kodları nasıl değiştirirsek bu mümkün olur. Teşekkürler.

Sub dosyaları_birlestir()
Dim fso As Object, f As Object, dosya As String, fls As Object
Dim sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste(), başlık()
Set fso = CreateObject("Scripting.FileSystemObject")
yoll = Cells(1, "s") & "\"
Set f = fso.getfolder(yoll).Files
ThisWorkbook.Activate
ThisWorkbook.Sheets("OKUL LİSTE").Select
Application.ScreenUpdating = False
Range("A1:r65536").ClearContents
For Each fls In f
If fso.GetExtensionName(fls) = "xls" Then
dosyaadı = dd
If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
For Each sh In Workbooks(fls.Name).Worksheets
başlık = sh.Range("A1:n1").Value
ThisWorkbook.Sheets("OKUL LİSTE").Range("A1").Resize(UBound(başlık), 14) = başlık
sonsat1 = sh.Cells(65536, "A").End(xlUp).Row
If sonsat1 >= 3 Then
liste = sh.Range("A1:n" & sonsat1).Value
sonsat2 = ThisWorkbook.Sheets("OKUL LİSTE").Cells(65536, "A").End(xlUp).Row + 1
ThisWorkbook.Sheets("OKUL LİSTE").Range("A" & sonsat2).Resize(UBound(liste), 14) = liste
ThisWorkbook.Sheets("OKUL LİSTE").Range("p" & sonsat2 + 1) = fls.Name
Erase liste
End If
Next sh
Workbooks(fls.Name).Close False
End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("OKUL LİSTE").Select

Columns("P").Select
Selection.Replace What:=".xls", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("P1").Select

Call sınıf_şube_öğrno
Application.ScreenUpdating = True
End Sub

 

[muygun]

Merhaba;
Aynı konu aynı alanda devam ederse daha yerinde olur.
Eki inceleyin. Gerekli görürseniz sabit sayfasını gizleyebilirsiniz.
İyi çalışmalar.

Link:
http://dosya.co/gnyt9rbhszd5/vurkan-ÖĞRENCİ_LİSANS_PROGRAMI-4.zip.html

 

[vurkan]

Sayın Muygun emeklerin için çok teşekkür ediyorum. Ellerin dert görmesin. Sağ ol var ol.