• DİKKAT

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

Seçeneğe Göre Rapordan Veri Çekme

K

kaos3

Katılım
30 Haziran 2008
Mesajlar
63
Excel Vers. ve Dili
excel 2010 tr
Merhabalar,

Yaklaşık bir haftadır sorunum hakkında yardımcı olabilecek konuları aradım ama bir türlü sonuç alamadım.
Ekteki Rapor Liste dosyasında da konuyu belirttim.

Elimde hergün artan bir Rapor sürüsü var ve bu raporların bazı verileri listede tutulması gerekiyor.
Rapor Liste isimli dosyada Butona tıkladığımda Raporlardaki verileri listede belirtilen konumlara çekebilecek bir makro hazırlayabilir miyiz?

Şimdiden Teşekkür Ederim.

Kolay gelsin.
 

Ekli dosyalar

Aynı Konu

kaos3' Alıntı:
Merhabalar,

Yaklaşık bir haftadır sorunum hakkında yardımcı olabilecek konuları aradım ama bir türlü sonuç alamadım.
Ekteki Rapor Liste dosyasında da konuyu belirttim.

Elimde hergün artan bir Rapor sürüsü var ve bu raporların bazı verileri listede tutulması gerekiyor.
Rapor Liste isimli dosyada Butona tıkladığımda Raporlardaki verileri listede belirtilen konumlara çekebilecek bir makro hazırlayabilir miyiz?

Şimdiden Teşekkür Ederim.

Kolay gelsin.
Genişletmek için tıkla ...

Merhabalar,

Bunu makro ile yazmak konusunda benim de bir talebim var. Ancak, bu isteğinizi yatayara ve düşey ara formülleri ile de yapabilirsiniz.

Kolaylıklar dilerim..
 
keyhusrev204' Alıntı:
Merhabalar,

Bunu makro ile yazmak konusunda benim de bir talebim var. Ancak, bu isteğinizi yatayara ve düşey ara formülleri ile de yapabilirsiniz.

Kolaylıklar dilerim..
Genişletmek için tıkla ...

Formüller Hakkında yardımcı olabilir misiniz aslında makro ile olması ilk tercihim ancak bi sonuç alamazsam formüllerlede deneyebilirim.
 
Son düzenleme:
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub VERILERI_AKTAR()
    Dim Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satir As Long, Dosya As Object, Kaynak_Dosya As Object, Sayfa As Worksheet
 
    On Error GoTo Son
 
    Application.ScreenUpdating = False
 
    Dosya_Yolu = ThisWorkbook.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
 
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa1")
 
    If SR.Cells(Rows.Count, 1).End(3).Row < 4 Then
        Satir = 4
    Else
        Satir = SR.Cells(Rows.Count, 1).End(3).Row + 1
    End If
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            If UCase(Left(Dosya.Name, 2)) = "UF" Then
                If WorksheetFunction.CountIf(SR.Range("A:A"), Val(Replace(Split(Dosya.Name, ".")(0), "UF", ""))) = 0 Then
                    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
                    Set Sayfa = Kaynak_Dosya.Sheets(1)
                    
                    SR.Cells(Satir, 1) = Sayfa.Range("X4")
                    SR.Cells(Satir, 2) = Sayfa.Range("X5")
                    SR.Cells(Satir, 3) = Sayfa.Range("E7")
                    SR.Cells(Satir, 4) = Sayfa.Range("E8")
                    SR.Cells(Satir, 5) = Sayfa.Range("E9")
                    SR.Cells(Satir, 6) = Sayfa.Range("V7")
                    SR.Cells(Satir, 7) = Sayfa.Range("V8")
                    SR.Cells(Satir, 8) = Sayfa.Range("V9")
                    SR.Cells(Satir, 9) = Sayfa.Range("B11")
                    If Sayfa.Range("E19") <> "" Then
                        SR.Cells(Satir, 10) = Sayfa.Range("D22")
                        SR.Cells(Satir, 11) = Sayfa.Range("M22")
                        SR.Cells(Satir, 12) = Sayfa.Range("U22")
                    End If
                    If Sayfa.Range("T19") <> "" Then
                        SR.Cells(Satir, 13) = Sayfa.Range("D22")
                        SR.Cells(Satir, 14) = Sayfa.Range("M22")
                        SR.Cells(Satir, 15) = Sayfa.Range("U22")
                    End If
                    If Sayfa.Range("E26") <> "" Then
                        SR.Cells(Satir, 16) = Sayfa.Range("D28")
                        SR.Cells(Satir, 17) = Sayfa.Range("M28")
                        SR.Cells(Satir, 18) = Sayfa.Range("U28")
                    End If
                    If Sayfa.Range("C32") <> "" Then
                        SR.Cells(Satir, 19) = Sayfa.Range("R40")
                        SR.Cells(Satir, 20) = Sayfa.Range("W40")
                    End If
                    If Sayfa.Range("P32") <> "" Then
                        SR.Cells(Satir, 21) = Sayfa.Range("R40")
                        SR.Cells(Satir, 22) = Sayfa.Range("W40")
                    End If
                    SR.Cells(Satir, 23) = Sayfa.Range("G33")
                    SR.Cells(Satir, 24) = Sayfa.Range("P33")
                    SR.Cells(Satir, 25) = Sayfa.Range("G34")
                    SR.Cells(Satir, 26) = Sayfa.Range("B36")
                    SR.Cells(Satir, 27) = Sayfa.Range("F36")
                    SR.Cells(Satir, 28) = Sayfa.Range("J36")
                    SR.Cells(Satir, 29) = Sayfa.Range("P36")
                    SR.Cells(Satir, 30) = Sayfa.Range("U36")
                    If Sayfa.Range("F50") <> "" Then
                        SR.Cells(Satir, 31) = Sayfa.Range("F51")
                        SR.Cells(Satir, 32) = Sayfa.Range("B52")
                    End If
                    If Sayfa.Range("R50") <> "" Then
                        SR.Cells(Satir, 33) = Sayfa.Range("R51")
                        SR.Cells(Satir, 34) = Sayfa.Range("O52")
                    End If
                    
                    Satir = Satir + 1
                    Kaynak_Dosya.Close 0
                End If
            End If
        End If
    Next
 
    Set Veri_Dosyası = Nothing
    Set SR = Nothing
    Set Kaynak_Dosya = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    If Not Kaynak_Dosya Is Nothing Then Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
 
Korhan Ayhan' Alıntı:
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub VERILERI_AKTAR()
    Dim Klasor As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satir As Long, Dosya As Object, Kaynak_Dosya As Object, Sayfa As Worksheet
 
    On Error GoTo Son
 
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
 
    If Klasor Is Nothing Then
        MsgBox "Klasor seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Dosya_Yolu = Klasor.Items.Item.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
 
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa1")
 
    If SR.Cells(Rows.Count).End(3).Row < 4 Then
        Satir = 4
    Else
        Satir = SR.Cells(Rows.Count).End(3).Row + 1
    End If
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            If UCase(Left(Dosya.Name, 2)) = "UF" Then
                If WorksheetFunction.CountIf(SR.Range("A:A"), Val(Replace(Split(Dosya.Name, ".")(0), "UF", ""))) = 0 Then
                    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
                    Set Sayfa = Kaynak_Dosya.Sheets(1)
                    
                    SR.Cells(Satir, 1) = Sayfa.Range("X4")
                    SR.Cells(Satir, 2) = Sayfa.Range("X5")
                    SR.Cells(Satir, 3) = Sayfa.Range("E7")
                    SR.Cells(Satir, 4) = Sayfa.Range("E8")
                    SR.Cells(Satir, 5) = Sayfa.Range("E9")
                    SR.Cells(Satir, 6) = Sayfa.Range("V7")
                    SR.Cells(Satir, 7) = Sayfa.Range("V8")
                    SR.Cells(Satir, 8) = Sayfa.Range("V9")
                    SR.Cells(Satir, 9) = Sayfa.Range("B11")
                    If Sayfa.Range("E19") <> "" Then
                        SR.Cells(Satir, 10) = Sayfa.Range("D22")
                        SR.Cells(Satir, 11) = Sayfa.Range("M22")
                        SR.Cells(Satir, 12) = Sayfa.Range("U22")
                    End If
                    If Sayfa.Range("T19") <> "" Then
                        SR.Cells(Satir, 13) = Sayfa.Range("D22")
                        SR.Cells(Satir, 14) = Sayfa.Range("M22")
                        SR.Cells(Satir, 15) = Sayfa.Range("U22")
                    End If
                    If Sayfa.Range("E26") <> "" Then
                        SR.Cells(Satir, 16) = Sayfa.Range("D28")
                        SR.Cells(Satir, 17) = Sayfa.Range("M28")
                        SR.Cells(Satir, 18) = Sayfa.Range("U28")
                    End If
                    If Sayfa.Range("C32") <> "" Then
                        SR.Cells(Satir, 19) = Sayfa.Range("R40")
                        SR.Cells(Satir, 20) = Sayfa.Range("W40")
                    End If
                    If Sayfa.Range("P32") <> "" Then
                        SR.Cells(Satir, 21) = Sayfa.Range("R40")
                        SR.Cells(Satir, 22) = Sayfa.Range("W40")
                    End If
                    SR.Cells(Satir, 23) = Sayfa.Range("G33")
                    SR.Cells(Satir, 24) = Sayfa.Range("P33")
                    SR.Cells(Satir, 25) = Sayfa.Range("G34")
                    SR.Cells(Satir, 26) = Sayfa.Range("B36")
                    SR.Cells(Satir, 27) = Sayfa.Range("F36")
                    SR.Cells(Satir, 28) = Sayfa.Range("J36")
                    SR.Cells(Satir, 29) = Sayfa.Range("P36")
                    SR.Cells(Satir, 30) = Sayfa.Range("U36")
                    If Sayfa.Range("F50") <> "" Then
                        SR.Cells(Satir, 31) = Sayfa.Range("F51")
                        SR.Cells(Satir, 32) = Sayfa.Range("B52")
                    End If
                    If Sayfa.Range("R50") <> "" Then
                        SR.Cells(Satir, 33) = Sayfa.Range("R51")
                        SR.Cells(Satir, 34) = Sayfa.Range("O52")
                    End If
                    
                    Satir = Satir + 1
                    Kaynak_Dosya.Close 0
                End If
            End If
        End If
    Next
 
    Set Klasor = Nothing
    Set Veri_Dosyası = Nothing
    Set SR = Nothing
    Set Kaynak_Dosya = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    If Not Kaynak_Dosya Is Nothing Then Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
Genişletmek için tıkla ...

Korhan Hocam ellerinize sağlık kod tam istediğim şekilde çalışıyor.
İlginiz için çok teşekkürler.
Beni yine büyük bi yükten kurtardınız.
Allah bu siteyi ve sizi başımızdan eksik etmesin.
 
Son düzenleme:
Korhan Ayhan' Alıntı:
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub VERILERI_AKTAR()
    Dim Klasor As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satir As Long, Dosya As Object, Kaynak_Dosya As Object, Sayfa As Worksheet
 
    On Error GoTo Son
 
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
 
    If Klasor Is Nothing Then
        MsgBox "Klasor seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Dosya_Yolu = Klasor.Items.Item.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
 
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa1")
 
    If SR.Cells(Rows.Count).End(3).Row < 4 Then
        Satir = 4
    Else
        Satir = SR.Cells(Rows.Count).End(3).Row + 1
    End If
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            If UCase(Left(Dosya.Name, 2)) = "UF" Then
                If WorksheetFunction.CountIf(SR.Range("A:A"), Val(Replace(Split(Dosya.Name, ".")(0), "UF", ""))) = 0 Then
                    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
                    Set Sayfa = Kaynak_Dosya.Sheets(1)
                    
                    SR.Cells(Satir, 1) = Sayfa.Range("X4")
                    SR.Cells(Satir, 2) = Sayfa.Range("X5")
                    SR.Cells(Satir, 3) = Sayfa.Range("E7")
                    SR.Cells(Satir, 4) = Sayfa.Range("E8")
                    SR.Cells(Satir, 5) = Sayfa.Range("E9")
                    SR.Cells(Satir, 6) = Sayfa.Range("V7")
                    SR.Cells(Satir, 7) = Sayfa.Range("V8")
                    SR.Cells(Satir, 8) = Sayfa.Range("V9")
                    SR.Cells(Satir, 9) = Sayfa.Range("B11")
                    If Sayfa.Range("E19") <> "" Then
                        SR.Cells(Satir, 10) = Sayfa.Range("D22")
                        SR.Cells(Satir, 11) = Sayfa.Range("M22")
                        SR.Cells(Satir, 12) = Sayfa.Range("U22")
                    End If
                    If Sayfa.Range("T19") <> "" Then
                        SR.Cells(Satir, 13) = Sayfa.Range("D22")
                        SR.Cells(Satir, 14) = Sayfa.Range("M22")
                        SR.Cells(Satir, 15) = Sayfa.Range("U22")
                    End If
                    If Sayfa.Range("E26") <> "" Then
                        SR.Cells(Satir, 16) = Sayfa.Range("D28")
                        SR.Cells(Satir, 17) = Sayfa.Range("M28")
                        SR.Cells(Satir, 18) = Sayfa.Range("U28")
                    End If
                    If Sayfa.Range("C32") <> "" Then
                        SR.Cells(Satir, 19) = Sayfa.Range("R40")
                        SR.Cells(Satir, 20) = Sayfa.Range("W40")
                    End If
                    If Sayfa.Range("P32") <> "" Then
                        SR.Cells(Satir, 21) = Sayfa.Range("R40")
                        SR.Cells(Satir, 22) = Sayfa.Range("W40")
                    End If
                    SR.Cells(Satir, 23) = Sayfa.Range("G33")
                    SR.Cells(Satir, 24) = Sayfa.Range("P33")
                    SR.Cells(Satir, 25) = Sayfa.Range("G34")
                    SR.Cells(Satir, 26) = Sayfa.Range("B36")
                    SR.Cells(Satir, 27) = Sayfa.Range("F36")
                    SR.Cells(Satir, 28) = Sayfa.Range("J36")
                    SR.Cells(Satir, 29) = Sayfa.Range("P36")
                    SR.Cells(Satir, 30) = Sayfa.Range("U36")
                    If Sayfa.Range("F50") <> "" Then
                        SR.Cells(Satir, 31) = Sayfa.Range("F51")
                        SR.Cells(Satir, 32) = Sayfa.Range("B52")
                    End If
                    If Sayfa.Range("R50") <> "" Then
                        SR.Cells(Satir, 33) = Sayfa.Range("R51")
                        SR.Cells(Satir, 34) = Sayfa.Range("O52")
                    End If
                    
                    Satir = Satir + 1
                    Kaynak_Dosya.Close 0
                End If
            End If
        End If
    Next
 
    Set Klasor = Nothing
    Set Veri_Dosyası = Nothing
    Set SR = Nothing
    Set Kaynak_Dosya = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    If Not Kaynak_Dosya Is Nothing Then Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
Genişletmek için tıkla ...


Korhan Hocam ,
Formül mükemmel çalışıyor.
Ancak UF ile başlayan formlar arttıkça (yani UF0005 eklendiğinde) kodu yeniden çalıştırdığımda altalta sıraya koymak yerine sırada en üstte olanı (yani UF0001 silip) onun yerine yeni eklenen rapordaki verileri çekiyor.
Bu durumu yeni ekleneni listede sıraya ekleyecek şekilde nasıl düzeltebiliriz?
Birde her butona tıkladığımda bana dosya yolunu sorması gereklimi onu bir defa belirtsem olabilir mi?
 
Merhaba,

Zaten üstteki mesajımda ki kodda "Satir" değişkenini hatalı kodlamışım. Hatalar bundan dolayı kaynaklanıyordur.

#5 nolu mesajımda ki kodu güncelledim. Klasör seçimini iptal ettim. Tekrar deneyiniz.

Not : Asıl dosya ile "UF" kodlu dosyalar aynı klasörde olmalıdır.
 
Korhan Ayhan' Alıntı:
Merhaba,

Zaten üstteki mesajımda ki kodda "Satir" değişkenini hatalı kodlamışım. Hatalar bundan dolayı kaynaklanıyordur.

#5 nolu mesajımda ki kodu güncelledim. Klasör seçimini iptal ettim. Tekrar deneyiniz.

Not : Asıl dosya ile "UF" kodlu dosyalar aynı klasörde olmalıdır.
Genişletmek için tıkla ...


Hocam Ellerinize Sağlık.
Kod mükemmel oldu tam istediğim gibi çalışıyor.
İyiki varsınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst