Skip to main content

AccessTr.neT


Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı

Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı

#19
Sayın @feraz bey Kitap isimlerini değiştirdim çalışıyor. Sayfa adlarına ek yaptığım adını değiştirdiğim zaman çalışmıyor. Son düzenlediğim macro sizin en son attığınız ve benim uyarladığım aşağıdaki gibi acaba hata nerededir?

[Resim: do.php?img=10999]
https://resim.accesstr.net/do.php?img=10999


Sub GetData()

Dim sFile As Workbook, tFile As Workbook
Dim dosya As String, kes, parcaAl, son As Long
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet

Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("İzin")
Set s2 = tFile.Sheets("Rapor")
Set s3 = tFile.Sheets("Ücretsiz")

Application.ScreenUpdating = False
    dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls*")
    s1.Cells.ClearContents: s2.Cells.ClearContents: s3.Cells.Clear
        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)
                If parcaAl Like "İzin*" Then
                    son = sFile.Worksheets("İzin").Cells(Rows.Count, 1).End(3).Row
                    sFile.Worksheets("İzin").Range("A1:E" & son).Copy s1.Cells(1, 1)
                ElseIf parcaAl Like "Rapor*" Then
                    son = sFile.Worksheets("Rapor").Cells(Rows.Count, 1).End(3).Row
                    sFile.Worksheets("Rapor").Range("A1:AA" & son).Copy s2.Cells(1, 1)
                ElseIf parcaAl Like "Ücretsiz*" Then
                    son = sFile.Worksheets("Ücretsiz").Cells(Rows.Count, 1).End(3).Row
                    sFile.Worksheets("Ücretsiz").Range("A1:K" & son).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: Set tFile = Nothing: parcaAl = vbNullString
    Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 08/05/2021, 06:01, Düzenleyen: yyhy.
Cevapla
#20
Tamam abey resme baktım halledince eklerim kodu.

Son dosyalarınızı eklemeniz gerekiyor hatalı şekilde ve klasörde exceller olacak şekilde çünkü değiştirmişsiniz.
Cevapla
#21
Alttaki gibi deneyin sanırım dosya eklemeniz için zamanınız yok.
Ýzin gibi çıktığı için oraları düzeltin kodda.
"Rapor*" yerine "*Rapor*" olarak değiştirisenizde içerirse olarak arar.

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 syfizin Then
                   syfparca.Range("A1:E" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).Copy s1.Cells(1, 1)
                ElseIf parcaAl Like syfRapor Then
                    syfparca.Range("A1:AA" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).Copy s2.Cells(1, 1)
                ElseIf parcaAl Like syfucretsiz Then
                    syfparca.Range("A1:K" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).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
Cevapla
#22
syfparca.Range("A1:K" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).Copy

Yukardaki gibilerin yerine alttakide olur.

syfparca.Range("A1").currentregion.offset(1).copy
Cevapla
#23
Sayın @feraz bey inanın son aşamaya geldim önceki sefer yazdığımda dosya eklememişim. Kodu bir türlü uyarlayamadım. İçerisinde kişisel bilgi olmayan asıl ana dosyam ile örnek dosyaları ekliyorum acaba bir deneyip foruma yükleme şansınız var mı acaba? Dosya ekleyemedim link olarak attım.
Ayrıca kitap isimleri ve sayfa isimleri joker karakter kullanabilirsek özellikle sayfa adında çok iyi olacak.
.rar Haftalık İstatistik 2021-004.rar (Dosya Boyutu: 148,88 KB | İndirme Sayısı: 1)
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 08/05/2021, 21:55, Düzenleyen: yyhy. (Sebep: Dosya eklendi.)
Cevapla
#24
Abey dosyanın çalışmaması normal çünkü resimdeki gibi exceladları farklı ile başlar yerine içerik olarak aratsak bukezde iki dosyada izin olarak geçiyor.

[Resim: do.php?img=11000]
https://resim.accesstr.net/do.php?img=11000
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task