• DİKKAT

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

Kapalı/Çoklu sayfalardan veri alma

A

Abdulhey

Katılım
8 Aralık 2005
Mesajlar
93
Excel Vers. ve Dili
Microsoft® Excel 2007 Tr
Merhaba üstadlar;

İlgili dosyamda isteğimi dile getirdim. Çoklu kapalı sayfadan şarta bağlı veri çekmek istiyorum.

Mümkünmüdür.

Deneme sayfasında açıklama mevcut
 

Ekli dosyalar

Dosyanız ektedir.:cool:
deneme.xlsm dosyanızda diğer dosyalarla ayni klasörde olamalıdır.
Kod: 
Sub degeryaz59()
Dim dosya As String, deg As String, sat1 As Long
Dim sat2 As Long, sh As Worksheet, i As Long, k As Range
ThisWorkbook.Activate
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
sat1 = 4
dosya = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While dosya <> ""
    If Workbooks.Open(ThisWorkbook.Path & "\" & dosya).ReadOnly Then
        Workbooks(dosya).Close False
    End If
    ThisWorkbook.Activate
    Set sh = Workbooks(dosya).Sheets("Sayfa1")
    sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
    Set k = sh.Range("A1:A" & sat2).Find(Range("A1").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(sat1, "A").Value = Replace(dosya, ".xlsx", "")
        Cells(sat1, "B").Value = k.Offset(o, 1).Value
        sat1 = sat1 + 1
    End If
    Set k = Nothing
    Set sh = Nothing
    Workbooks(dosya).Close False
    dosya = Dir
Loop
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

Abdülhey Bey, yarın dosyanızla ilgilenmeye çalışacağım...

İyi geceler...


Evren Bey cevap vermiş bile... :)

Saygılar.
 
deneme.xlsm dosyanızda diğer dosyalarla ayni klasörde olamalıdır.
Genişletmek için tıkla ...

Merhaba;
Eğer burdaki olmalıdır ise hata veriyor. Klasör dışına çıkardığım zaman işlem tamam diyor ancak sonucu getirmiyor.
deneme.xls a1 hücresinde "b" değeri var ama diğer sayfalardaki b değerini yazmıyor.
 
Abdulhey' Alıntı:
Merhaba;
Eğer burdaki olmalıdır ise hata veriyor. Klasör dışına çıkardığım zaman işlem tamam diyor ancak sonucu getirmiyor.
deneme.xls a1 hücresinde "b" değeri var ama diğer sayfalardaki b değerini yazmıyor.
Genişletmek için tıkla ...
Gerekli düzenlemeyi yaptım.
Dosyayı 4 nolu mesajdan indirebilirisiniz::cool:
 
Orion1' Alıntı:
Gerekli düzenlemeyi yaptım.
Dosyayı 4 nolu mesajdan indirebilirisiniz::cool:
Genişletmek için tıkla ...

Şahane. Teşekkürler.

Affınıza sığınarak bir ekleme yapayım.

Şu haliyle excell sayfalarından deneme sayfasına şarta göre veri çağırıyor.

20120518,20120519.xlx ... sayfalarında c,d,e,f .. satırlarında olan verileride deneme.xls sayfasına yazdırmak istesek nasıl bir ekleme yapmamız gerekir ?

Teşekkürler.
 
Abdulhey' Alıntı:
Şahane. Teşekkürler.

Affınıza sığınarak bir ekleme yapayım.

Şu haliyle excell sayfalarından deneme sayfasına şarta göre veri çağırıyor.

20120518,20120519.xlx ... sayfalarında c,d,e,f .. satırlarında olan verileride deneme.xls sayfasına yazdırmak istesek nasıl bir ekleme yapmamız gerekir ?

Teşekkürler.
Genişletmek için tıkla ...
İlgili yeri aşağıdaki kod ile değiştiriniz.:cool:
Kod: 
If Not k Is Nothing Then
        Cells(sat1, "A").Value = Replace(dosya, ".xlsx", "")
        Cells(sat1, "B").Value = k.Offset(0, 1).Value
        Cells(sat1, "C").Value = k.Offset(0, 2).Value
        Cells(sat1, "D").Value = k.Offset(0, 3).Value
        Cells(sat1, "E").Value = k.Offset(0, 4).Value
        Cells(sat1, "F").Value = k.Offset(0, 5).Value
        sat1 = sat1 + 1
    End If
 
Orion1' Alıntı:
İlgili yeri aşağıdaki kod ile değiştiriniz.:cool:
Kod: 
If Not k Is Nothing Then
        Cells(sat1, "A").Value = Replace(dosya, ".xlsx", "")
        Cells(sat1, "B").Value = k.Offset(0, 1).Value
        Cells(sat1, "C").Value = k.Offset(0, 2).Value
        Cells(sat1, "D").Value = k.Offset(0, 3).Value
        Cells(sat1, "E").Value = k.Offset(0, 4).Value
        Cells(sat1, "F").Value = k.Offset(0, 5).Value
        sat1 = sat1 + 1
    End If
Genişletmek için tıkla ...

Teşekkürler. Çok makbule geçti. Klavyene, bilgine sağlık....
 
Sayın Orion1 üstadım.
Örnek sayfayı yapmak istediğm çalışmaya enteğre edemedim. Veri aldığım sayfa ile veriyi getirdiğim yerler tutmayınca çuvalladım.

Asıl çalışacağım sayfa örneğim ekte. İlgilenebilirseniz sevinirim.
 

Ekli dosyalar

Abdulhey' Alıntı:
Sayın Orion1 üstadım.
Örnek sayfayı yapmak istediğm çalışmaya enteğre edemedim. Veri aldığım sayfa ile veriyi getirdiğim yerler tutmayınca çuvalladım.

Asıl çalışacağım sayfa örneğim ekte. İlgilenebilirseniz sevinirim.
Genişletmek için tıkla ...
dosyanız ektedir.:cool:
Kod: 
Sub degeryaz59_V2()
Dim dosya As String, deg As String, sat1 As Long
Dim sat2 As Long, sh As Worksheet, i As Long, k As Range
ThisWorkbook.Activate
Sheets("Geçici Kapanış Bülteni").Select
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).ClearContents
sat1 = 2
dosya = Dir(ThisWorkbook.Path & "\*.xls?")
Do While dosya <> "" And dosya <> ThisWorkbook.Name
    If Workbooks.Open(ThisWorkbook.Path & "\" & dosya).ReadOnly Then
        Workbooks(dosya).Close False
    End If
    ThisWorkbook.Activate
    Set sh = Workbooks(dosya).Sheets("Geçici Kapanış Bülteni")
    sat2 = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
    Set k = sh.Range("I1:I" & sat2).Find(Range("M1").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(sat1, "A").Value = Replace(dosya, ".xls", "")
        Cells(sat1, "B").Value = sh.Cells(k.Row, "L").Value
        Cells(sat1, "C").Value = sh.Cells(k.Row, "T").Value
        Cells(sat1, "D").Value = sh.Cells(k.Row, "X").Value
        Cells(sat1, "E").Value = sh.Cells(k.Row, "AD").Value
        Cells(sat1, "F").Value = sh.Cells(k.Row, "AH").Value
        sat1 = sat1 + 1
    End If
    Set k = Nothing
    Set sh = Nothing
    Workbooks(dosya).Close False
    dosya = Dir
Loop
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst