• DİKKAT

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

Başka sayfalardan veri almak.

S

sinan05

Katılım
16 Kasım 2017
Mesajlar
255
Excel Vers. ve Dili
office professional plus 2021
iyi günler herkeze iyi çalışmalar.Rica etsem bir formülde yardım edebilirmisniz. Yapmak istediğim şey şu; çalışma kitabımda 1 ve 2 adlarını taşıyan iki sayfam var. 2.sayfada b1 sütununda tarihler c2 sütununda isimler var ve d,e,f,g.h sütunlarında da başka veriler var. şimdi 1. sayfanın a1 hücresine başlangıç a2 hücresinede bitiş tarihi giriyorum.bu iki hücre arasındaki tarihe uyan 2. sayfadaki b,c,d,e,f,g,h sütunlarındaki bilgiler 1.sayfada listelense olurmu.
örneğin 1. sayfada 01.01.2017-30.01.2017 tarihlerini yazdığımda 2.sayfadaki şu şekilde tasarladığım 30.01.2017 - ahmet demir - vs... diye devam eden hücreler 1.sayfada listelense. yardımcı olursanız çok sevinirim. herkese teşekkürler.
 
sinan05' Alıntı:
Hocam çok hızlısınız maşallah. süper olmuş tam istediğim gibi. ALLAH (C.C) Razı olsun çok çok teşekkürler.bişey rica etsem acaba sonraki ı,j,k sütunlarınıda ekleyebilirmisniz.birde nekadar veri girebilirim aşağı sınırsızmı devam ediyor.
Genişletmek için tıkla ...
Teşekkür ederim, bilmukabele
Aşağıdaki mavi ve kırmızı değişikliklerle "I:K" aralığıda ekelenecektir.
Sınır yok ama döngü ile çalıştığı için 2. sayfada satır sayısı arttıkça verilerin gelme hızı yavaşlayacaktır, deneyin; aşırı satır varsa dizi ile yapmaya çalışırız.
Kod: 
[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" And Target.Address <> "$A$2" Then Exit Sub
Range("[COLOR="Blue"]A3:J" & Rows[/COLOR].Count).ClearContents
If IsDate([A1].Value) = False Then MsgBox "  İLK TARİHİ GİRİNİZ !  ": Exit Sub
If IsDate([A2].Value) = False Then MsgBox "  SON TARİHİ GİRİNİZ !  ": Exit Sub
With Sheets("Sayfa2")
s = 3
X = .Cells(Rows.Count, "B").End(3).Row
tar1 = CDate([A1])
tar2 = CDate([A2])
If CDbl(CDate(tar1)) > CDbl(CDate(tar2)) Then MsgBox "İLK TARİH SON TARİHTEN BÜYÜK OLAMAZ !": Exit Sub
For i = 2 To X
tarih = CDate(.Cells(i, 2))
If tarih >= tar1 And tarih <= tar2 Then
s = s + 1
[COLOR="Red"]Range("A" & s & ":J" & s).Value = .Range("B" & i & ":K" & i).Value[/COLOR]
End If
Next
End With
End Sub [/SIZE]
 
PLİNT' Alıntı:
Teşekkür ederim, bilmukabele
Aşağıdaki mavi ve kırmızı değişikliklerle "I:K" aralığıda ekelenecektir.
Sınır yok ama döngü ile çalıştığı için 2. sayfada satır sayısı arttıkça verilerin gelme hızı yavaşlayacaktır, deneyin; aşırı satır varsa dizi ile yapmaya çalışırız.
Kod: 
[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" And Target.Address <> "$A$2" Then Exit Sub
Range("[COLOR="Blue"]A3:J" & Rows[/COLOR].Count).ClearContents
If IsDate([A1].Value) = False Then MsgBox "  İLK TARİHİ GİRİNİZ !  ": Exit Sub
If IsDate([A2].Value) = False Then MsgBox "  SON TARİHİ GİRİNİZ !  ": Exit Sub
With Sheets("Sayfa2")
s = 3
X = .Cells(Rows.Count, "B").End(3).Row
tar1 = CDate([A1])
tar2 = CDate([A2])
If CDbl(CDate(tar1)) > CDbl(CDate(tar2)) Then MsgBox "İLK TARİH SON TARİHTEN BÜYÜK OLAMAZ !": Exit Sub
For i = 2 To X
tarih = CDate(.Cells(i, 2))
If tarih >= tar1 And tarih <= tar2 Then
s = s + 1
[COLOR="Red"]Range("A" & s & ":J" & s).Value = .Range("B" & i & ":K" & i).Value[/COLOR]
End If
Next
End With
End Sub [/SIZE]
Genişletmek için tıkla ...




hocam tekrar tekrar sağolun. çok işime yardı. eksik olmayın çok teşekkür ederim. hayırlı geceler.
 
sinan05' Alıntı:
hocam tekrar tekrar sağolun. çok işime yardı. eksik olmayın çok teşekkür ederim. hayırlı geceler.
Genişletmek için tıkla ...
Rica ederim, kolay gelsin.
Aşağıdaki örnek dizi ile yapılmış daha hızlı alternatifi:
http://s8.dosya.tc/server5/gugo7x/trh2.zip.html
Kod: 
[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" And Target.Address <> "$A$2" Then Exit Sub
Range("A3:J" & Rows.Count).ClearContents
If IsDate([A1].Text) = False Then MsgBox "  İLK TARİHİ GİRİNİZ !  ": Exit Sub
If IsDate([A2].Text) = False Then MsgBox "  SON TARİHİ GİRİNİZ !  ": Exit Sub
With Sheets("Sayfa2")
s = 0
x = .Cells(Rows.Count, "B").End(3).Row
tar1 = CDate([A1])
tar2 = CDate([A2])
If CDbl(CDate(tar1)) > CDbl(CDate(tar2)) Then MsgBox "İLK TARİH SON TARİHTEN BÜYÜK OLAMAZ !": Exit Sub
Dim lis(): Dim syf()
syf = .Range("B1:K" & x).Value
ReDim lis(1 To 10, 1 To x)
For i = 2 To x
If IsEmpty(syf(i, 1)) = False And IsDate(syf(i, 1)) = True Then
tarih = CDate(syf(i, 1))
If tarih >= tar1 And tarih <= tar2 Then
s = s + 1
For m = 1 To 10
lis(m, s) = syf(i, m)
Next
End If
End If
Next
End With
If s > 0 Then Cells(3, 1).Resize(x, 10) = Application.Transpose(lis)
End Sub[/SIZE]
 
PLİNT' Alıntı:
Rica ederim, kolay gelsin.
Aşağıdaki örnek dizi ile yapılmış daha hızlı alternatifi:
http://s8.dosya.tc/server5/gugo7x/trh2.zip.html
Kod: 
[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" And Target.Address <> "$A$2" Then Exit Sub
Range("A3:J" & Rows.Count).ClearContents
If IsDate([A1].Text) = False Then MsgBox "  İLK TARİHİ GİRİNİZ !  ": Exit Sub
If IsDate([A2].Text) = False Then MsgBox "  SON TARİHİ GİRİNİZ !  ": Exit Sub
With Sheets("Sayfa2")
s = 0
x = .Cells(Rows.Count, "B").End(3).Row
tar1 = CDate([A1])
tar2 = CDate([A2])
If CDbl(CDate(tar1)) > CDbl(CDate(tar2)) Then MsgBox "İLK TARİH SON TARİHTEN BÜYÜK OLAMAZ !": Exit Sub
Dim lis(): Dim syf()
syf = .Range("B1:K" & x).Value
ReDim lis(1 To 10, 1 To x)
For i = 2 To x
If IsEmpty(syf(i, 1)) = False And IsDate(syf(i, 1)) = True Then
tarih = CDate(syf(i, 1))
If tarih >= tar1 And tarih <= tar2 Then
s = s + 1
For m = 1 To 10
lis(m, s) = syf(i, m)
Next
End If
End If
Next
End With
If s > 0 Then Cells(3, 1).Resize(x, 10) = Application.Transpose(lis)
End Sub[/SIZE]
Genişletmek için tıkla ...



Vay canına süpersiniz hocam zahmet verdim.ne güzel süpriz oldu benim için. Çok sağolun elleriniz dert görmesin. Çok makbule geçti. Nekadar teşekkür etsem azdır. Tekrar sağolun.
 
sinan05' Alıntı:
Vay canına süpersiniz hocam zahmet verdim.ne güzel süpriz oldu benim için. Çok sağolun elleriniz dert görmesin. Çok makbule geçti. Nekadar teşekkür etsem azdır. Tekrar sağolun.
Genişletmek için tıkla ...


Hocam merhabalar. Rahatsız etmezsem ve uygunsa bir yardım isteyebilirmiyim. altta belirtmiş olduğum kodu makro kaydet diye oluşturdum.şimdi makronun yapmasını istediğim şey örnek taslak sayfasını kopyalasın müşteri kayıt sayfasındaki seçili kısmı yeni kopyaladığı sayfaya yapıştırsın ve yeni sayfanın isminide sayfanın kendi içindeki B3 hücresini versin. herşeyi yapıyor ama altı çizili kısımda hata veriyor sayfayı isimlendiremiyor. tabi ben altı çizili kısmı değiştirdim. yardımcı olabilirseniz çok sevinirim.

Sub Makro1()
'
' Makro1 Makro
'

'
Range("F12").Select
Sheets("ÖRNEK TASLAK").Select
Sheets("ÖRNEK TASLAK").Copy After:=Sheets(6)
Sheets("müşteri kayıt").Select
Range("A1:E23").Select
Selection.Copy
Sheets("ÖRNEK TASLAK (2)").Select
Range("A1:B2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("B3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("ÖRNEK TASLAK (2)").Select
Sheets("ÖRNEK TASLAK (2)")S.Name = Sheets ("B1").
Range("C24").Select
Sheets("müşteri kayıt").Select
End Sub
 
PLİNT' Alıntı:
Rica ederim, kolay gelsin.
Aşağıdaki örnek dizi ile yapılmış daha hızlı alternatifi:
http://s8.dosya.tc/server5/gugo7x/trh2.zip.html
Kod: 
[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" And Target.Address <> "$A$2" Then Exit Sub
Range("A3:J" & Rows.Count).ClearContents
If IsDate([A1].Text) = False Then MsgBox "  İLK TARİHİ GİRİNİZ !  ": Exit Sub
If IsDate([A2].Text) = False Then MsgBox "  SON TARİHİ GİRİNİZ !  ": Exit Sub
With Sheets("Sayfa2")
s = 0
x = .Cells(Rows.Count, "B").End(3).Row
tar1 = CDate([A1])
tar2 = CDate([A2])
If CDbl(CDate(tar1)) > CDbl(CDate(tar2)) Then MsgBox "İLK TARİH SON TARİHTEN BÜYÜK OLAMAZ !": Exit Sub
Dim lis(): Dim syf()
syf = .Range("B1:K" & x).Value
ReDim lis(1 To 10, 1 To x)
For i = 2 To x
If IsEmpty(syf(i, 1)) = False And IsDate(syf(i, 1)) = True Then
tarih = CDate(syf(i, 1))
If tarih >= tar1 And tarih <= tar2 Then
s = s + 1
For m = 1 To 10
lis(m, s) = syf(i, m)
Next
End If
End If
Next
End With
If s > 0 Then Cells(3, 1).Resize(x, 10) = Application.Transpose(lis)
End Sub[/SIZE]
Genişletmek için tıkla ...






Hocam merhabalar. Rahatsız etmezsem ve uygunsa bir yardım isteyebilirmiyim. altta belirtmiş olduğum kodu makro kaydet diye oluşturdum.şimdi makronun yapmasını istediğim şey örnek taslak sayfasını kopyalasın müşteri kayıt sayfasındaki seçili kısmı yeni kopyaladığı sayfaya yapıştırsın ve yeni sayfanın isminide sayfanın kendi içindeki B3 hücresini versin. herşeyi yapıyor ama altı çizili kısımda hata veriyor sayfayı isimlendiremiyor. tabi ben altı çizili kısmı değiştirdim. yardımcı olabilirseniz çok sevinirim.

Sub Makro1()
'
' Makro1 Makro
'

'
Range("F12").Select
Sheets("ÖRNEK TASLAK").Select
Sheets("ÖRNEK TASLAK").Copy After:=Sheets(6)
Sheets("müşteri kayıt").Select
Range("A1:E23").Select
Selection.Copy
Sheets("ÖRNEK TASLAK (2)").Select
Range("A1:B2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("B3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("ÖRNEK TASLAK (2)").Select
Sheets("ÖRNEK TASLAK (2)")S.Name = Sheets ("B1").
Range("C24").Select
Sheets("müşteri kayıt").Select
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst