BELİRLİ BİR KLASÖRDEKİ DOSYALARDAN VERİ ALMA

Erdinç FIRTINA · 14 Temmuz 2019

Değerli üyeler,

Aşağıdaki düzenlemeyi belirli zaman öncesinde Sayın Evren Gizlen yapmıştı. Söz konusu kodlarla adı belirli bir klasör içindeki dosyaların belirlenen sayfasından veriler alınıyordu. Örneğin; NEDİR Klasörü içindeki dosyaların Sheet1 sf larındaki veriler alınıp AKTARILANSF sayfasına alt alta aktarılıyordu. Ancak, ilgili kodlarla bu işlem yapılamıyor. Sadece bir tek dosyanın verileri alınıyor, diğer dosyaların verileri alınamıyor. Kodlarda nasıl bir yanlış yapmış olabilirim?

Yardımlarınız için çok çok teşekkürler!!!

Sub aktar()
Dim sat1 As Long, i As Long, sut As Byte, yol As String
Dim dosya As String, sat2 As Long, sh As Worksheet
Application.ScreenUpdating = False
sat1 = 1
yol = ThisWorkbook.Path & "\NEDİR\" 'dosyalar klasörün adı
With Sheets("AKTARILANSF") 'verilerin alınacağı sayfa adı
.Range("B1:BU" & Rows.Count).ClearContents
dosya = Dir(yol & "*.xls")
Do While dosya <> ""
If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
Set sh = ActiveWorkbook.Sheets("Sheet1") 'verilerin alınacağı dosyada ki sayfa adı
sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
If sat2 > 2 Then
sh.Range("A1:H" & sat2).Copy
.Range("B" & sat1).PasteSpecial
Application.CutCopyMode = False
Set sh = Nothing
End If
dosya = Dir
ActiveWorkbook.Close False
sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Loop
End With
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı." & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
Sheets("AKTARILANSF").Select
Range("Q1").Select
MsgBox "işlem tamamlandı."
End Sub

Muzaffer Ali · 14 Temmuz 2019

Merhaba.
Verileri "B" sütununa yapıştırıyorsunuz. "A" sütunu sürekli boş kalıyor.
Boş sütuna yapıştırılan veri olmadığı için "sat" değişkeni her zaman 2 değerini alıyor ve her dosyadan kopyalanan veriler 2. satırdan itibaren yapıştırılıyor.
Bu hatayı gidermek için "B" sütunundaki ilk boş satırı bulmanız gerekiyor.

Kod:

sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1

satırındaki "A" yı "B" yapmalısınız.

Kod:

sat1 = .Cells(Rows.Count, "B").End(xlUp).Row + 1

Erdinç FIRTINA · 15 Temmuz 2019

dalgalikur' Alıntı:
Merhaba.
Verileri "B" sütununa yapıştırıyorsunuz. "A" sütunu sürekli boş kalıyor.
Boş sütuna yapıştırılan veri olmadığı için "sat" değişkeni her zaman 2 değerini alıyor ve her dosyadan kopyalanan veriler 2. satırdan itibaren yapıştırılıyor.
Bu hatayı gidermek için "B" sütunundaki ilk boş satırı bulmanız gerekiyor.

Kod:

sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1

satırındaki "A" yı "B" yapmalısınız.

Kod:

sat1 = .Cells(Rows.Count, "B").End(xlUp).Row + 1

Sayın dalgalikur,

Yardımlarınız için çok çok teşekkür ederim!!!

nomercy99 · 24 Mayıs 2022

Muzaffer Ali' Alıntı:
Merhaba.
Verileri "B" sütununa yapıştırıyorsunuz. "A" sütunu sürekli boş kalıyor.
Boş sütuna yapıştırılan veri olmadığı için "sat" değişkeni her zaman 2 değerini alıyor ve her dosyadan kopyalanan veriler 2. satırdan itibaren yapıştırılıyor.
Bu hatayı gidermek için "B" sütunundaki ilk boş satırı bulmanız gerekiyor.

Kod:

sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1

satırındaki "A" yı "B" yapmalısınız.

Kod:

sat1 = .Cells(Rows.Count, "B").End(xlUp).Row + 1

Merhabalar,

Bu konuyla ilgili ek bir bilgi rica edebilir miyim?Verileri 2 farklı klasörden çekmek istediğimizde nasıl bir düzenleme yapmamız gerekir?

Muzaffer Ali · 24 Mayıs 2022

İkinci klasör ile birinci klasör aynı yerdeyse
Aşağıdaki satırda "İKİNCİ KLASÖR" yerine klasör adını yazın.
yol = ThisWorkbook.Path & "\İKİNCİ KLASÖR\"

İkinci klasör farklı bir yerdeyse aşağıdaki gibi tam yolunu yazın.
yol = "c:\Yeni Klasör\İKİNCİ KLASÖR\"

Kod:

Sub aktar()
    Dim sat1 As Long, i As Long, sut As Byte, yol As String
    Dim dosya As String, sat2 As Long, sh As Worksheet
    Application.ScreenUpdating = False
    sat1 = 1
    yol = ThisWorkbook.Path & "\NEDİR\" 'dosyalar klasörün adı
    With Sheets("AKTARILANSF") 'verilerin alınacağı sayfa adı
        .Range("B1:BU" & Rows.Count).ClearContents
        dosya = Dir(yol & "*.xls")
        Do While dosya <> ""
            If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
            Set sh = ActiveWorkbook.Sheets("Sheet1") 'verilerin alınacağı dosyada ki sayfa adı
            sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
            If sat2 > 2 Then
                sh.Range("A1:H" & sat2).Copy
                .Range("B" & sat1).PasteSpecial
                Application.CutCopyMode = False
                Set sh = Nothing
            End If
            dosya = Dir
            ActiveWorkbook.Close False
            sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Loop
        
        yol = ThisWorkbook.Path & "\İKİNCİ KLASÖR\" 
        dosya = Dir(yol & "*.xls")
        Do While dosya <> ""
            If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
            Set sh = ActiveWorkbook.Sheets("Sheet1") 'verilerin alınacağı dosyada ki sayfa adı
            sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
            If sat2 > 2 Then
                sh.Range("A1:H" & sat2).Copy
                .Range("B" & sat1).PasteSpecial
                Application.CutCopyMode = False
                Set sh = Nothing
            End If
            dosya = Dir
            ActiveWorkbook.Close False
            sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Loop
    End With
    Application.ScreenUpdating = True
    MsgBox "işlem tamamlandı." & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
    Sheets("AKTARILANSF").Select
    Range("Q1").Select
    MsgBox "işlem tamamlandı."
End Sub

nomercy99 · 24 Mayıs 2022

Muzaffer Ali' Alıntı:
İkinci klasör ile birinci klasör aynı yerdeyse

nomercy99 · 24 Mayıs 2022

Muzaffer Ali' Alıntı:

İkinci klasör ile birinci klasör aynı yerdeyse
Aşağıdaki satırda "İKİNCİ KLASÖR" yerine klasör adını yazın.
yol = ThisWorkbook.Path & "\İKİNCİ KLASÖR\"

İkinci klasör farklı bir yerdeyse aşağıdaki gibi tam yolunu yazın.
yol = "c:\Yeni Klasör\İKİNCİ KLASÖR\"

Kod:

Sub aktar()
    Dim sat1 As Long, i As Long, sut As Byte, yol As String
    Dim dosya As String, sat2 As Long, sh As Worksheet
    Application.ScreenUpdating = False
    sat1 = 1
    yol = ThisWorkbook.Path & "\NEDİR\" 'dosyalar klasörün adı
    With Sheets("AKTARILANSF") 'verilerin alınacağı sayfa adı
        .Range("B1:BU" & Rows.Count).ClearContents
        dosya = Dir(yol & "*.xls")
        Do While dosya <> ""
            If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
            Set sh = ActiveWorkbook.Sheets("Sheet1") 'verilerin alınacağı dosyada ki sayfa adı
            sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
            If sat2 > 2 Then
                sh.Range("A1:H" & sat2).Copy
                .Range("B" & sat1).PasteSpecial
                Application.CutCopyMode = False
                Set sh = Nothing
            End If
            dosya = Dir
            ActiveWorkbook.Close False
            sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Loop
       
        yol = ThisWorkbook.Path & "\İKİNCİ KLASÖR\"
        dosya = Dir(yol & "*.xls")
        Do While dosya <> ""
            If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
            Set sh = ActiveWorkbook.Sheets("Sheet1") 'verilerin alınacağı dosyada ki sayfa adı
            sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row
            If sat2 > 2 Then
                sh.Range("A1:H" & sat2).Copy
                .Range("B" & sat1).PasteSpecial
                Application.CutCopyMode = False
                Set sh = Nothing
            End If
            dosya = Dir
            ActiveWorkbook.Close False
            sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Loop
    End With
    Application.ScreenUpdating = True
    MsgBox "işlem tamamlandı." & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
    Sheets("AKTARILANSF").Select
    Range("Q1").Select
    MsgBox "işlem tamamlandı."
End Sub

Çok teşekkür ederim, çok işime yaradı

nomercy99 · 27 Mayıs 2022

Hocam Tekrar Merhabalar;

Bu formülü dosyalar ----yol = ThisWorkbook.Path & "\NEDİR\" 'dosyalar klasörün adı---- şeklinde bir klasör içerisinde değil de,içerisinde bulunduğu klasörden tarayabilir mi?Kendime uyarladığım şekilde kodunu altta gönderiyorum.Fakat devamlı hata alıyorum.Nerede hata yapıyorum?Yardımcı olabilirseniz çok sevinirim

Kod:

Sub Satılanları_düş()


Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "SATILAN"

Dim sat1 As Long, i As Long, sut As Byte, yol As String
Dim dosya As String, sat2 As Long, sh As Worksheet
Application.ScreenUpdating = False
sat1 = 2
yol = "C:\Users\Pazarlama\OneDrive\Pazarlama1\"  'dosyalar klasörün adı
With Sheets("SATILAN") 'verilerin alınacağı sayfa adı
.Range("A2:B" & Rows.Count).ClearContents
dosya = Dir(yol & "*.xlsm")
Do While dosya <> "sipariş dosyası"
If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
Set sh = ActiveWorkbook.Sheets("ÖZET SİPARİŞ") 'verilerin alınacağı dosyada ki sayfa adı
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row




If sat2 > 2 Then
sh.Range("A3:B" & sat2).Copy
.Range("A" & sat1).PasteSpecial


Application.CutCopyMode = False
Set sh = Nothing
End If
dosya = Dir
ActiveWorkbook.Close False
sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Loop
 yol = "C:\Users\Pazarlama\OneDrive\Pazarlama2\" 'dosyalar klasörün adı
        dosya = Dir(yol & "*.xlsm")
        Do While dosya <> "sipariş dosyası"
            If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
            Set sh = ActiveWorkbook.Sheets("ÖZET SİPARİŞ") 'verilerin alınacağı dosyada ki sayfa adı
            sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
            If sat2 > 2 Then
                sh.Range("A3:B" & sat2).Copy
                .Range("A" & sat1).PasteSpecial
                Application.CutCopyMode = False
                Set sh = Nothing
            End If
            dosya = Dir
            ActiveWorkbook.Close False
            sat1 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Loop
End With
Application.ScreenUpdating = True

Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("SİPARİŞ SAYFASI")
Set s2 = ThisWorkbook.Worksheets("SATILAN")
For i = 2 To s2.Range("A65536").End(xlUp).Row
If s2.Cells(i, "c") = "" Then
For k = 3 To s1.Range("b65536").End(xlUp).Row
If s1.Cells(k, "b") = s2.Cells(i, "a") Then
s1.Cells(k, "e") = s1.Cells(k, "e") - s2.Cells(i, "b")
s2.Cells(i, "c") = Date
End If
Next k
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
    



End Sub

BELİRLİ BİR KLASÖRDEKİ DOSYALARDAN VERİ ALMA

Erdinç FIRTINA

Muzaffer Ali

Destek Ekibi

Erdinç FIRTINA

nomercy99

Muzaffer Ali

Destek Ekibi

nomercy99

nomercy99

nomercy99