AccessTr.neT
Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı (/konu-klasor-icerisindeki-3-yardimci-kitaptan-ana-kitaba-veri-aktarimi.html)

Sayfalar: 1 2 3 4 5 6


RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 08/05/2021

İzin ibarelerini kaldırayım Dr.Raporu, Senelik, Ücretsiz olarak düzelteyim/düzeltip o şekilde uyarlayabilir misiniz?


RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021

Son dosyanıza göre alttaki kod çalışıyor.Tabii kalasördeki gibi isimlerle başlaması gerek.

Sub GetData()

Dim sFile As Workbook, syfparca As Worksheet
Dim dosya As String, kes, parcaAl
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet

Const syfizin As String = "Ýzin"
Const syfRapor As String = "Rapor"
Const syfucretsiz As String = "Ücretsiz"

Dim syf As Worksheet

    For Each syf In ThisWorkbook.Worksheets
        If syf.Name Like syfizin Then
            Set s1 = syf: s1.Cells.Clear
        ElseIf syf.Name Like syfRapor Then
            Set s2 = syf: s2.Cells.Clear
        ElseIf syf.Name Like syfucretsiz Then
            Set s3 = syf: s3.Cells.Clear
        End If
    Next

Application.ScreenUpdating = False
    dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls*")
        Do While dosya <> ""
            If dosya <> ThisWorkbook.Name Then
                Set sFile = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dosya)
                kes = Split(dosya, ".")
                parcaAl = Mid(dosya, 1, Len(dosya) - Len(kes(UBound(kes))) - 1)
                Set syfparca = Workbooks(parcaAl).Sheets("Sayfa1")
             
                If parcaAl Like "*Senelik " & syfizin & "*" Then
                  syfparca.Range("A1").CurrentRegion.Copy s1.Cells(1, 1)
                ElseIf parcaAl Like "*Dr." & syfRapor & "*" Then
                    syfparca.Range("A1").CurrentRegion.Copy s2.Cells(1, 1)
                ElseIf parcaAl Like "*" & syfucretsiz & " Ýzin*" Then
                    syfparca.Range("A1").CurrentRegion.Copy s3.Cells(1, 1)
                End If
                kes = "": sFile.Close
            End If
            Application.CutCopyMode = False
            dosya = Dir
        Loop
    Application.ScreenUpdating = True
    s1.Activate
    s1.Cells(1, 1).Activate
    MsgBox "Bitti"
    Set sFile = Nothing: parcaAl = vbNullString
    Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set syf = Nothing
End Sub

(08/05/2021, 22:40)yyhy yazdı: İzin ibarelerini kaldırayım Dr.Raporu, Senelik, Ücretsiz olarak düzelteyim/düzeltip o şekilde uyarlayabilir misiniz?
Bence daha garanti olur abey.


RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 08/05/2021

Sayın @feraz bey dosya içerisine kodu yerleştirip ana dosyayı buraya ekleyebilir misiniz? Bir terslik var kusura bakmayın kodu aldım bir yerde hata yapıyorum.


RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021

(08/05/2021, 23:00)yyhy yazdı: Sayın @feraz bey dosya içerisine kodu yerleştirip ana dosyayı buraya ekleyebilir misiniz? Bir terslik var kusura bakmayın kodu aldım bir yerde hata yapıyorum.
Tamam abey dışarı çıkıyorum gelince eklerim.


Re: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021

Abey dosya ekte.
Dikkat edilmesi gerekenler alttaki gibi baslaması gerek klasördeki Excel isimleri

Senelik İzin ve Ücretsiz İzin buralarda harfler arasında boşluk olmsada olur koda replace ekledim.

Senelik İzin
Ücretsiz İzin
Dr.Rapor


RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 08/05/2021

Teşekkürler emeğinize sağlık.