klasörde bulunan her dosyadan veri alma

desk · 16 Ocak 2009

hafta kısmında 1 yazdığım zaman süzebiliyorum 1 den 5 e kadar yada 5 den 12 ye kadar veya tüm haftaları süzmeyi nasıl yapabilirim? 1,2 yaptığımda işlemi yapmıyor?

Korhan Ayhan · 16 Ocak 2009

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod;

Kod:

Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim İlk_Süre As Date, Son_Süre As Date, Toplam_Süre As Date
    Dim Klasör() As String, Hafta() As String, X As Integer, Y As Integer
    Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
    Dim Dosya_Yolu As String, Satır As Long
    Dim Bul As Range, Adres As String
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    İlk_Süre = Time
    
    Set Veri_Dosyası = ThisWorkbook
    
    If Veri_Dosyası.Sheets("Sayfa1").Range("C10") <> "" And Veri_Dosyası.Sheets("Sayfa1").Range("C11") <> "" Then
    
    Hafta = Split(Veri_Dosyası.Sheets("Sayfa1").Range("C11"), ",")
    
    Klasör = Split(Veri_Dosyası.Sheets("Sayfa1").Range("C10"), ",")
    
    Veri_Dosyası.Sheets("Sayfa1").Range("A14:E65536").ClearContents
    
    For X = 0 To UBound(Klasör())
    
    Dosya_Yolu = Veri_Dosyası.Path & "\" & Klasör(X)
    
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
    
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    
    Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        
        Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
    
            For Y = 0 To UBound(Hafta())
            
                Set Bul = [B:B].Find(Hafta(Y), LookAt:=xlWhole)
                
                If Not Bul Is Nothing Then
                
                Adres = Bul.Address
                
                Do
                
                If Cells(Bul.Row, 3) = "ÜRETİM" Then
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 1) = Cells(Bul.Row, 1)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 2) = Replace(Kaynak_Dosya.Name, ".xls", "")
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) = Cells(Bul.Row, 2)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 4) = Cells(Bul.Row, 3)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4)
                Satır = Satır + 1
                End If
                        
                Set Bul = [B:B].FindNext(Bul)
                
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
                
                End If
            
            Next
    
        Kaynak_Dosya.Close True
    
    Next
    
    End If
    Next
    End If
    
    Son_Süre = Time
    
    Toplam_Süre = Format(Son_Süre - İlk_Süre, "hh:mm:ss")
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi ; " & Toplam_Süre, vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

desk · 17 Ocak 2009

If Cells(Bul.Row, 3) = "ÜRETİM" Then
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 1) = Cells(Bul.Row, 1)
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 2) = Replace(Kaynak_Dosya.Name, ".xls", "")
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) = Cells(Bul.Row, 2)
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 4) = Cells(Bul.Row, 3)
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4)
Satır = Satır + 1
End If

Şu bölümü hafta 2 ise giren i 1000 ile çarp ve yaz, 5 ise 2000 ile çarp yaz yapabilirmiyiz 6 ıncı satıra.?

Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 6) = End If Cells(Bul.Row, 4) = "1" and "5" Then Cells(Bul.Row, 4) * 1000 else Cells(Bul.Row, 4) * 2000

gibi birsey

desk · 17 Ocak 2009

şurdaki gibi

Korhan Ayhan · 18 Ocak 2009

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim İlk_Süre As Date, Son_Süre As Date, Toplam_Süre As Date
    Dim Klasör() As String, Hafta() As String, X As Integer, Y As Integer
    Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
    Dim Dosya_Yolu As String, Satır As Long
    Dim Bul As Range, Adres As String
 
    On Error GoTo Son
 
    Application.ScreenUpdating = False
 
    İlk_Süre = Time
 
    Set Veri_Dosyası = ThisWorkbook
 
    If Veri_Dosyası.Sheets("Sayfa1").Range("C10") <> "" And Veri_Dosyası.Sheets("Sayfa1").Range("C11") <> "" Then
 
    Hafta = Split(Veri_Dosyası.Sheets("Sayfa1").Range("C11"), ",")
 
    Klasör = Split(Veri_Dosyası.Sheets("Sayfa1").Range("C10"), ",")
 
    Veri_Dosyası.Sheets("Sayfa1").Range("A14:G65536").ClearContents
 
    For X = 0 To UBound(Klasör())
 
    Dosya_Yolu = Veri_Dosyası.Path & "\" & Klasör(X)
 
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
    Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
 
        Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
            For Y = 0 To UBound(Hafta())
 
                Set Bul = [C:C].Find(Hafta(Y), LookAt:=xlWhole)
 
                If Not Bul Is Nothing Then
 
                Adres = Bul.Address
 
                Do
 
                If Cells(Bul.Row, 4) = "ÜRETİM" Then
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 1) = Cells(Bul.Row, 1)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 2) = Replace(Kaynak_Dosya.Name, ".xls", "")
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) = Cells(Bul.Row, 2)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 4) = Cells(Bul.Row, 3)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4)
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 6) = Cells(Bul.Row, 5)
                If Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) <> 4 And Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) <> 6 Then
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 7) = Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 6) * 1000
                Else
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 7) = Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 6) * 2000
                End If
                Satır = Satır + 1
                End If
 
                Set Bul = [C:C].FindNext(Bul)
 
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
 
                End If
 
            Next
 
        Kaynak_Dosya.Close True
 
    Next
 
    End If
    Next
    End If
 
    Son_Süre = Time
 
    Toplam_Süre = Format(Son_Süre - İlk_Süre, "hh:mm:ss")
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi ; " & Toplam_Süre, vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

desk · 20 Ocak 2009

Bunların alt toplamlarını aldırmayı yapamadım yardım edebilirmisin.

senyok · 20 Ocak 2009

Sayfalardan veri çekme

Bu konu benim yapmak istediğime çok yakın duruyor, o yüzden burayı seçtim. bir Excel dosyasında diyelim ki 100 sayfa(sheet) bulunsun. Ben sözgelimi, her sheet'teki B2 hücresini tek bir excel sheetînde alt alta sıralamak istiyorum. yani B2 hücrelerinden oluşan 100 satırlık bir veri elde etmek istiyorum. Bu konuda yardımcı olabilirseniz çok sevinirim.

Korhan Ayhan · 21 Ocak 2009

Selamlar,

Sn. senyok,

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Kod:

Option Explicit
 
Sub SAYFALARDAKİ_B2_HÜCRELERİNİ_LİSTELE()
    Dim Sayfa As Worksheet, Satır As Long
    On Error GoTo Ekle
    Sheets("LİSTE").Select
    [A:A].ClearContents
    GoTo Devam
Ekle:
    Worksheets.Add
    ActiveSheet.Name = "LİSTE"
Devam:
    Satır = 1
    For Each Sayfa In Worksheets
    If Sayfa.Name <> "LİSTE" Then
    Sheets("LİSTE").Cells(Satır, 1) = Sayfa.[B2]
    Satır = Satır + 1
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

senyok · 21 Ocak 2009

Kayhan Bey, çok teşekkür ederim hakikaten. Diyelim ki b2 nin yanına da b3 üde listelemek istiyorum. Bu durumda, kodu tam olarak nereye eklemem gerekir. Gerçekten çok teşekkür ediyorum bu arada, Allah razı olsun

Korhan Ayhan · 21 Ocak 2009

Selamlar,

Sheets("LİSTE").Cells(Satır, 1) = Sayfa.[B2] satırından sonra aşağıdaki satırı eklerseniz B3 hücrelerinide alabilirsiniz.

Kod:

Sheets("LİSTE").Cells(Satır, [COLOR=red]2[/COLOR]) = Sayfa.[B[COLOR=red]3[/COLOR]]

Ayrıca [A:A].ClearContents satırınıda [A:B].ClearContents olarak değiştirmelisiniz.

senyok · 21 Ocak 2009

Korhan Bey, çok çok teşekkür ediyorum size. Bu arada benim excel iyidir ama hiç makro ile ilgilenmemiştim bu zamana kadar, fakat artık görüyorum ki ilgilenmek gerekiyor. Son bir soru: Verileri çekerken, diyelim ki ikinci satırdan başlatmak istiyorum. Yani, ilk satıra isimleri giricem bu nasıl olur...

Ben internet ortamında, tanımadığınız bir kişi için böylesine bir yardımı ilk kez görüyorum ve gerçekten çok mutlu oldum, bu yardımseverliğiniz için.

senyok · 21 Ocak 2009

Ha tamam onu kendim bulmuştum.. İyi günler diliyorum, Allah razı olsun.

Korhan Ayhan · 21 Ocak 2009

Selamlar,

Sizler bilgilenmek isterseniz bizler elimizden geldiğince ve bilgilerimiz doğrultusunda paylaşıma her zaman hazırız.

Verileri ikinci satırdan almak için Satır = 1 değişkenini Satır = 2 olarak değiştirmelisiniz.

Ayrıca silme işlemi yapan koduda değiştirmelisiniz. Yoksa makroyu her çalıştırdığınızda yazdığınız başlıklarda silinecektir. Aşağıdaki şekilde uygulayın.

[A:B].ClearContents satırınıda [A2:B65536].ClearContents olarak değiştirmelisiniz.

SaNSiFu · 11 Şubat 2012

Çalışma için teşekkürler öncelikle, eski bir konu biliyorum ama tabloyu olduğu gibi listelemesini istesek olurmu örneğin

Kod:

A  B  C  D
1  1  1  1
2  2  2  2

hem sutün hemde satırları listelete bilirmiyiz...

klasörde bulunan her dosyadan veri alma

desk

Korhan Ayhan

Administrator

Ekli dosyalar

desk

desk

Ekli dosyalar

Korhan Ayhan

Administrator

desk

senyok

Korhan Ayhan

Administrator

Ekli dosyalar

senyok

Korhan Ayhan

Administrator

senyok

senyok

Korhan Ayhan

Administrator

SaNSiFu