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ı

#7
Merhaba.
Atoykan hocamızın kodunu alttaki gibi düzenledim.

Sub GetData()

Dim sFile As Workbook, tFile As Workbook
Dim dosya As String

Set tFile = ThisWorkbook

Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.*")
With tFile.Worksheets("Senelik Mazeret")
    .Range("A2:E" & Rows.Count).ClearContents
        Do While dosya <> ""
            If dosya <> ThisWorkbook.Name Then
                Set sFile = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dosya)
                sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
                .Activate
                .Cells(Rows.Count, 1).End(3).Offset(1, 0).Select
              .Paste
                Application.CutCopyMode = False
                sFile.Close
            End If
            dosya = Dir
        Loop
    Set sFile = Nothing
    Set tFile = Nothing
    Application.ScreenUpdating = True
   
    ThisWorkbook.Activate
    .Activate
    .Range("A1").Select
End With
MsgBox "Bitti"
End Sub

Gerçi mantık hatası var ayarlayınca eklerim.
Sayfa1 yazmışsınız ondan kafalar karıştı.
Cevapla
#8
Alttaki kod işinizi görür.Çalışmazsa Tr karakterlerini düzeltin.

Sub GetData()

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

Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("Senelik Mazeret")
Set s2 = tFile.Sheets("Dr.Raporlu Sevk")
Set s3 = tFile.Sheets("Ücretsiz")

Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.*")
    With s1
        .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
    End With

    With s2
        .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
    End With
   
    With s3
        .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
    End With
   
        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 = "Liste1(Senelik Mazeret)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy _
                    s1.Cells(Rows.Count, 1).End(3).Offset(1, 0)
                    Application.CutCopyMode = False
                ElseIf parcaAl = "Liste2(Dr.Raporlu Sevk)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy _
                    s2.Cells(Rows.Count, 1).End(3).Offset(1, 0)
                    Application.CutCopyMode = False
                ElseIf parcaAl = "Liste3(Ücretsiz)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy _
                    s3.Cells(Rows.Count, 1).End(3).Offset(1, 0)
                    Application.CutCopyMode = False
                End If
                Application.CutCopyMode = False
                sFile.Close
            End If
            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

Sadece deger ve formatlar kopyalansın derseniz koddaki ilgili yerleri alttaki gibi değiştirin.

If parcaAl = "Liste1(Senelik Mazeret)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
                    s1.Cells(Rows.Count, 1).End(3).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False
ElseIf parcaAl = "Liste2(Dr.Raporlu Sevk)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
                    s2.Cells(Rows.Count, 1).End(3).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False
ElseIf parcaAl = "Liste3(Ücretsiz)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
                    s3.Cells(Rows.Count, 1).End(3).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False
  End If
Cevapla
#9
Bu kodda başlıklarla birlikte alır verileri.
Kolay gelsin.


Sub GetData()

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

Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("Senelik Mazeret")
Set s2 = tFile.Sheets("Dr.Raporlu Sevk")
Set s3 = tFile.Sheets("Ücretsiz")

Application.ScreenUpdating = False
    dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.*")
    s1.Cells.ClearContents: s2.Cells.ClearContents: s3.Cells.ClearContents
        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 = "Liste1(Senelik Mazeret)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Copy s1.Cells(1, 1)
                ElseIf parcaAl = "Liste2(Dr.Raporlu Sevk)" Then
                    sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Copy s2.Cells(1, 1)
                ElseIf parcaAl = "Liste3(Ücretsiz)" Then
                    sFile.Worksheets("Sayfa1").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: Set tFile = Nothing: parcaAl = vbNullString
    Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub
Cevapla
#10
Tamam @feraz bey deneyip bilgi vereyim. Teşekkür ederim.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#11
Sayın @feraz bey uzantı ile ilgi bir şey göremedim ama *.* olarak mı ayarladınız? Şuan sorun yok güzel çalışıyor. Emeğinize sağlık. @atoykan beye de teşekkür ederim. Son noktayı siz koydunuz. Emeğinize sağlık.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 07/05/2021, 02:06, Düzenleyen: yyhy.
Cevapla
#12
*.* bu tüm dosya uzantılarını arar abey *.xlsm* yaparsanız ona göre arar.
Rica ederim.
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task