• DİKKAT

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

Soru Birden fazla kapalı dosyadan veri alma

V

valentino06

Katılım
19 Şubat 2007
Mesajlar
630
Excel Vers. ve Dili
Ofis 365 Tr- 64 Bit
Merhaba,
Günaydın Arkadaşlar birden fazla kapalı excel kitaplarından veri almak istiyorum. bir dosya içinde belki aynı formatta 100 ile 150 arasında kapalı excel kitaplarım var. bu kitaplardaki hepsi aynı formatta olan verileri data sayfasındaki boyalı alanlara sıralı olarak getirmek istiyorum.getirmek istediğim alanları boyadım.excel kitaplarını hepsini ve aynı zamanda istediğim kitapları seçerek getirme olasılığımız var ise seçerek getirmek istiyorum. lütfen siz değerli hocalarımın yardımına ihtiyacım var. çok teşekkür ederim.
 

Ekli dosyalar

Merhaba,
Arkadaşlar lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.
 
Arkadaşlar lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.
 
Arkadaşlar lütfen yardımcı olabilirmisiniz. Allah razı olsun.
 
Arkadaşlar lütfen yardımcı olabilirmisiniz. Çok teşekkür ederim.
 
Hocalarım lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.
 
Kod: 
Sub ImportDataFromMultipleWorkbooks()

    Dim vaFiles As Variant
    Dim wbkToCopy As Workbook
    Dim ws As Worksheet
    Dim wsa As Worksheet

    ThisWorkbook.Activate

    Set ws = Sheet2

    un = "Dear " & Environ("UserName")

    ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks", vbInformation + vbYesNo, un)
    If ms1 = vbYes Then
        Intersect(ws.Range("4:175"), ws.Range("C:E,F:F,H:H,J:J,L:L,O:O,R:R")).ClearContents

        ChDir (ThisWorkbook.Path)
        vaFiles = Application.GetOpenFilename( _
                  FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
                  Title:="Select Files to Proceed", MultiSelect:=True)
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = False
        End With
        say = 4
        If IsArray(vaFiles) Then
            For i = LBound(vaFiles) To UBound(vaFiles)
                If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                    ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                    GoTo skipfile:
                End If
                Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
                Set wsa = ActiveWorkbook.ActiveSheet
                ws.Cells(say, "C") = wsa.Range("B2")
                ws.Cells(say, "D") = wsa.Range("B1")
                ws.Cells(say, "E") = wsa.Range("B5")
                ws.Cells(say, "F") = wsa.Range("P4")
                ws.Cells(say, "H") = wsa.Range("Q4")
                ws.Cells(say, "J") = wsa.Range("S4")
                ws.Cells(say, "L") = wsa.Range("T4")
                ws.Cells(say, "O") = wsa.Range("B3")
                ws.Cells(say, "R") = wsa.Range("B4")
                wbkToCopy.Close savechanges:=False
                say = say + 1
skipfile:
            Next i
            ms5 = MsgBox("Data Import Finished", vbInformation, un)
        Else
            ms3 = MsgBox("No Files Selected", vbExclamation, un)
        End If
    Else
        ms2 = MsgBox("Cancelled", vbInformation, un)
    End If

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub
 
Merhaba,
Veyselemre hocam çok teşekkür ederim kod güzel çalışıyor. yalnız şöyle bir sorun var yeni bir tane eklediğimde diğer ekli olanları siliyor. sürekli kod sayfası açılıyor.Veysel hocam her yeni ekleme yaptığımda silmeden alt alta getirme olasılığımız varmı. ellerinize ve emeğinize sağlık çok teşekkür ederim.
 
Kod: 
Sub ImportDataFromMultipleWorkbooks()

    Dim vaFiles As Variant
    Dim wbkToCopy As Workbook
    Dim ws As Worksheet
    Dim wsa As Worksheet

    ThisWorkbook.Activate

    Set ws = Sheet2

    un = "Dear " & Environ("UserName")

    ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks", vbInformation + vbYesNo, un)
    If ms1 = vbYes Then
        'Intersect(ws.Range("4:175"), ws.Range("C:E,F:F,H:H,J:J,L:L,O:O,R:R")).ClearContents

        ChDir (ThisWorkbook.Path)
        vaFiles = Application.GetOpenFilename( _
                  FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
                  Title:="Select Files to Proceed", MultiSelect:=True)
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = False
        End With
        say = ws.Cells(175, 3).End(3).Row + 1
        If IsArray(vaFiles) Then
            For i = LBound(vaFiles) To UBound(vaFiles)
                If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                    ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                    GoTo skipfile:
                End If
                Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
                Set wsa = ActiveWorkbook.ActiveSheet
                ws.Cells(say, "A") = wsa.Name
                ws.Cells(say, "C") = wsa.Range("B2")
                ws.Cells(say, "D") = wsa.Range("B1")
                ws.Cells(say, "E") = wsa.Range("B5")
                ws.Cells(say, "F") = wsa.Range("P4")
                ws.Cells(say, "H") = wsa.Range("Q4")
                ws.Cells(say, "J") = wsa.Range("S4")
                ws.Cells(say, "L") = wsa.Range("T4")
                ws.Cells(say, "O") = wsa.Range("B3")
                ws.Cells(say, "R") = wsa.Range("B4")
                wbkToCopy.Close savechanges:=False
                say = say + 1
skipfile:
            Next i
            ms5 = MsgBox("Data Import Finished", vbInformation, un)
        Else
            ms3 = MsgBox("No Files Selected", vbExclamation, un)
        End If
    Else
        ms2 = MsgBox("Cancelled", vbInformation, un)
    End If

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub
 
Merhaba,
Arkadaşlar Veysel hocamın yaptığı kod çok güzel çalışıyor. çektiğimiz bu verilerin güncelleme işlemini yapabilirmiyiz. değerli hocalarımdan destek bekliyorum. çok teşekkür ederim.
 
Arkadaşlar çekmiş olduğum verileri güncellemede lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.
 
Arkadaşlar lütfen yardımcı olabilirmisiniz.Çok teşekkür ederim.
 
Hayırlı Cumalar Arkadaşlar lütfen yardımcı olabilirmisiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst