• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kopyala, Özel Yapıştır, İşlemi Tersine Çevir.

U

usta07

Destek Ekibi
Destek Ekibi
Katılım
30 Mart 2008
Mesajlar
405
Excel Vers. ve Dili
2003 Türkçe
Aynı klasör içerisinde, birden fazla (yaklaşık30) dosyalardaki PRD1 ve PRD2 sayfalarındaki A100:Z113 aralığındaki bilgileri kopyalayıp
DEPO isimli dosyadaki Veri sayfasına alt alta özel yapıştır, değerleri, işlemi tersine çevir şeklinde olmak kaydı ile bir kod'a ihtiyacım var.
Sayın Halit ÖZDEMİR'İN bir çalışmasından esinlenerek yapmaya çalıştığım ancak kodda işlemi tersine çevirme olayını ve dosya içindeki birden fazla sayfadan aldırmayı yapamadım. Vakit ayırıp ilgilenebilecek arkadaşlara teşekkür ederim.
örnek dosya eklenmiştir.

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim sat As String
Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat = 2
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Kalasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "PRD1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
For r = 100 To 113
For i = 1 To 30
Cells(sat, i) = ExecuteExcel4Macro(deg & r & "C" & i)
If Cells(sat, i) = 0 Then
Cells(sat, i) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

  • KKY.rar
    KKY.rar
    36.2 KB · Görüntüleme: 16
Bunu denermisiniz.

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim sat As String
Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Kalasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
son = 2
If ThisWorkbook.Name <> Dosya Then
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "PRD1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
For i = 1 To 30
sut = 1
For r = 99 To 113
Cells(sat, sut) = ExecuteExcel4Macro(deg & r & "C" & son)
If Cells(sat, sut) = 0 Then
Cells(sat, sut) = ""
End If
sut = sut + 1
Next r
son = son + 1
sat = Cells(Rows.Count, "A").End(3).Row + 1
Next i
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 
Sayın Halit ÖZDEMİR,
İlgilerinize teşekkür ederim.
Dosyalarda ki PRD2 sayfalarından bilgi almıyor, çünkü tanımlı değil.
aşağıdaki satırları ilave ettiğimde
Kod: 
deg1 = "'" & Kalasor & "\" & "[" & Dosya & "]" & "PRD2" & "'!R"
ve
Kod: 
Cells(sat, sut) = ExecuteExcel4Macro(deg1 & r & "C" & son)

If Cells(sat, sut) = 0 Then satırında takılıyor.
İlk mesajda da belirttiğim gibi dosyalardaki PRD2 sayfalarından da aynı yere aynı şekilde bilgi getirmesi için Nasıl bir ilave yaparsam çalışır.
İlgilerinize Tekrar teşekkür ederim.
 
Ekli dosyada data sayfasındaki komut düğmesine tıkla ve veri dosyalarına ait klasörü bul
deneme sayfasına bütün verileri getirmektedir.

not: arka planda userform çalışmaktadır burada yapılan data sayfasına dosyaların sayfa isimleri alınıyor ve buradaki sayfa isimlerinden deneme sayfasına veriler alınıyor.
 

Ekli dosyalar

Merhaba,

Bende bir kod hazırlamıştım. Alternatif olarak denermisiniz.

Kod: 
Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim FSO As Object, DOSYA As Object, DOSYA_YOLU As Object, DOSYALAR As Object
    Dim X As Integer, Y As Byte, Satır As Long, Sütun As Byte, İlk As Byte
    Dim Sayfalar As Variant, Sayfa As Byte, Say As Byte
    
    Application.ScreenUpdating = False
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DOSYA_YOLU = FSO.GetFolder(ThisWorkbook.Path)
    Set DOSYALAR = DOSYA_YOLU.Files
    
    Sayfalar = Array("PRD1", "PRD2")
    
    Range("A2:Z" & Rows.Count).ClearContents
    Range("A2:Z" & Rows.Count).NumberFormat = "General"
    Range("B2:B" & Rows.Count).NumberFormat = "m/d/yyyy"
    Range("E2:E" & Rows.Count).NumberFormat = "@"
    Satır = 2
    Sütun = 1
    
    For Each DOSYA In DOSYALAR
        If DOSYA.Name <> "DEPO.xls" Then
            For Sayfa = 0 To UBound(Sayfalar)
                İlk = IIf(Say > 0, 2, 1)
                For Y = İlk To 26
                    For X = 99 To 113
                        Cells(Satır, Sütun) = ExecuteExcel4Macro("'" & DOSYA_YOLU & "\[" & DOSYA.Name & "]" & Sayfalar(Sayfa) & "'!R" & X & "C" & Y)
                        If IsError(Cells(Satır, Sütun)) Then
                            Cells(Satır, Sütun) = ""
                            GoTo Devam
                        End If
                        If Cells(Satır, Sütun) = 0 Then Cells(Satır, Sütun) = ""
                        Sütun = Sütun + 1
                    Next
                    Sütun = 1
                    Satır = Satır + 1
                Next
                Say = Say + 1
                Satır = Cells(Rows.Count, 1).End(3).Row + 1
            Next
        End If
Devam:
    Next
    
    Cells.EntireColumn.AutoFit
    
    Set FSO = Nothing
    Set DOSYA_YOLU = Nothing
    Set DOSYALAR = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Sayın Halit ÖZDEMİR,
Maalesef olmadı, eksik bilgi kritik bir hata ve ben bu hatayı göze alamam. Sayfalardaki alınması gereken verilerilerin bazılarının son sütundaki bilgileri getirmiyor. Dosya3 PRD1 hariç diğer sayfalarda ki bilgilerin son sütundaki bilgiler gelmiyor. Bu kadar uzun kod, form yerine, kes kopyala özel yapıştır işimi görecekti sanada bir sürü zahmet verdik, Bu mübarek günlerde tüm emeklerin için Allah razı olsun hakkını helal et Teşekkür ederim.
 
usta07' Alıntı:
Sayın Halit ÖZDEMİR,
Maalesef olmadı, eksik bilgi kritik bir hata ve ben bu hatayı göze alamam. Sayfalardaki alınması gereken verilerilerin bazılarının son sütundaki bilgileri getirmiyor. Dosya3 PRD1 hariç diğer sayfalarda ki bilgilerin son sütundaki bilgiler gelmiyor. Bu kadar uzun kod, form yerine, kes kopyala özel yapıştır işimi görecekti sanada bir sürü zahmet verdik, Bu mübarek günlerde tüm emeklerin için Allah razı olsun hakkını helal et Teşekkür ederim.
Genişletmek için tıkla ...

Aktar kodunda
aşağıdaki 15 değerini 16 yap

Kod: 
For i = 1 To [COLOR=red]15[/COLOR]
 
Kodun bu kadar uzun olaması veri alınacak sayfaların tam bilinmemesinden kaynaklanıyor.
Bu durumda kod baya uzun oluyor.
Veri alınacak dosyaların içinde kaç tane sayfa varsa adı ne olursa olsun verileri getiriyor.
eksik gelen veriyide düzelttim.
 

Ekli dosyalar

Sayın Korhan AYHAN,
Tek kelime ile mükemmel ve tam zamanında!!
Elinize aklınıza sağlık Allah ilminizi artırsın.
Çok Teşekkür ederim.
 
halit3' Alıntı:
Kodun bu kadar uzun olaması veri alınacak sayfaların tam bilinmemesinden kaynaklanıyor.
Bu durumda kod baya uzun oluyor.
Veri alınacak dosyaların içinde kaç tane sayfa varsa adı ne olursa olsun verileri getiriyor.
eksik gelen veriyide düzelttim.
Genişletmek için tıkla ...

Sayın Halit ÖDEMİR,
Evet şimdi düzelmiş, düşündüklerimizi yazıya tam dökemediğimiz için olacak ki sizleri çok uğraştırıyoruz. hakkınızı helal edin çok teşekkür ederim.
şunu da belirtmeden geçmeyim Korhan Bey'in çalışması ayrı bir ilaç gibi geldi.
 
Buda sizin veri sayfanıza aktarıyor sorgu sormadan.
not:dosya ile veri dosyaları aynı klasörde olmalı

P,Q,R sutünları veri alınacak dosyaya ait klasörü,dosyayı,sayfaları göstermektedir.

1-data sayfasında istenen dosyanın istenen sayfasınıda açabilirsiniz.
2-aktar2 düğmesi data sayfasız direk verileri alıyor.
3-alt klasörlerdeki verileride alıyor.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst