Soru Birden fazla kapalı dosyadan veri alma

[valentino06]

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.

 

[valentino06]

Merhaba,
Arkadaşlar lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz. Allah razı olsun.

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz. Çok teşekkür ederim.

 

[valentino06]

Arkadaşlar bir fikri olan yok mu?

 

[PLİNT]

Merhaba
Dosyanızı burayada ekleyip adres verirmisiniz?
https://www.dosyaupload.com/

 

[valentino06]

Teşekkür ederim. Hocam

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz.

 

[valentino06]

Hocalarım lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.

 

[veyselemre]

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

 

[valentino06]

Hocam Allah Kat Kat razı olsun. çok teşekkür ederim.

 

[valentino06]

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.

 

[veyselemre]

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

 

[valentino06]

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.

 

[valentino06]

Arkadaşlar çekmiş olduğum verileri güncellemede lütfen yardımcı olabilirmisiniz. çok teşekkür ederim.

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz.

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz.Çok teşekkür ederim.

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilirmisiniz

 

[valentino06]

Hayırlı Cumalar Arkadaşlar lütfen yardımcı olabilirmisiniz.