• DİKKAT

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

yüzlerce dosyanın aynı yerinden alma

X

xcfk01

Katılım
22 Mart 2010
Mesajlar
19
Excel Vers. ve Dili
microsoft office professional 2010
ihtiyacım olan şey yüzlerce ( takribi 600) farklı adda ve aynı biçim de dosyadan belirli satırları alarak boş bir excel sayfasına altalta yapıştırmak

ya da manuel ellee tek tek aç yapıştırla ne parmak kalır ne kafa :)

ekte bir dosyanın genel boş görünümü var 2 sayfadan oluşan dosyanın bana lazım olan sayfa ismi hepsinde aynı "Sheet1" . ben bunun 9. ve 49. satırlarını yani başlık (gün ad yer vs.) ve toplam bilgilerini (başlıkların karşılığı) istiyorum. bu verileride bahsettiğim gibi açık olan sayfama altalta yapıştırmak istiyorum

klasör seçimli olursa daha mükemmel olur ; guruplama imkanım olur

ne kadar arasamda bir türlü tıpatıp konuyu bulamadım denk gelemedim yada makro yazmayı bilemediğimden sonuca ulaşamadım.

yardımlarınızı rica ediyorum.

şimdiden teşekkürler:p
 

Ekli dosyalar

cevap verebilecek bir arkadaş varmı..
 
satırların birleştirileceği dosyanın kod modülüne kopyalayın.

Kod: 
Sub Farkli_Dosyalardan_2_Satir_Birlestir()

    Dim fName As String, fPath As String
    Dim wb As Workbook, wbData As Workbook, ws As Worksheet

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    Set wb = ThisWorkbook
    
    On Error Resume Next
    Set ws = wb.Worksheets("konsolide")
    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws.Name = "konsolide"
    Else
        ws.Cells.Clear
    End If
    On Error GoTo 0
    
    fPath = "C:\Dosyalar\" 'gerçek klasör ismi ile değiştir. sondaki \ unutulmamalı.
    fName = Dir(fPath & "*.xl*")
    
    Do While Len(fName) > 0
        Set wbData = Workbooks.Open(fPath & fName)
        wbData.Worksheets("Sheet1").Rows(9).EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbData.Worksheets("Sheet1").Rows(49).EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbData.Close False
        fName = Dir
    Loop

    Application.EnableEvents = True

End Sub
 
Son düzenleme:
bu da klasörü el ile seçerek...

Kod: 
Sub Farkli_Dosyalardan_2_Satir_Birlestir_Klasor_Sec()

    Dim fName As String, fPath As String
    Dim wb As Workbook, wbData As Workbook, ws As Worksheet

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    Set wb = ThisWorkbook
    
    On Error Resume Next
    Set ws = wb.Worksheets("konsolide")
    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws.Name = "konsolide"
    Else
        ws.Cells.Clear
    End If
    On Error GoTo 0
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        End If
    End With
    MsgBox fPath
    fName = Dir(fPath & "*.xl*")
    
    Do While Len(fName) > 0
        Set wbData = Workbooks.Open(fPath & fName)
        wbData.Worksheets("Sheet1").Rows(9).EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbData.Worksheets("Sheet1").Rows(49).EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbData.Close False
        fName = Dir
    Loop

    Application.EnableEvents = True

End Sub
 
teşekkürü borç biliyorum
yarın ilgili datalar elime gelecek ve denemesini yapacağım reelde
tekrar teşekkürler
 
Son düzenleme:
denemesini yaptım formül %100 çalışıyor

lakin unutmuş olduğum birşey var. tüm bu dosyalar bağlantılı ve formüllü

çıkan sonuç formül ve kısayollardan ibaret :(

kısacası bu kodlara (özellikle alttaki ) sadece değerleri yapıştırmasını nasıl ekleyebiliriz.

teşekkürler
 
birde yeni farkketiğim birşey bağlantıyı izleyince gördüm 49. satı için kod yerinde ama 9. satır için kod 2 şer 2ş er atlayarak çalışıyor

yani ilk dosya için 9. satır
2. için 11. satır
diye böyle gidiyor

kod satırı aynı ama sonuç farklı şaşırdım :???:
 
49 sabit ve 9 her dosya için 2 satır atlıyorsa yüzlerce dosya içinde belli bir dosyada 49 = 49 olmaz mı...

ayrıca hangi dosyada 9, hangisinde 11, 13, 15, 55, 147, vs anlamak için dosya adından çakarılabilecek bir veri var mı?

örneğin dosya isimleri 1.xlsx (9. satır), 2.xlsx (11. satır), 3.xlsx (13. satır) vb gibi bir durum var mı?

yoksa, başka ayırt edici veri lazım.

örneğin her dosyada tekrar eden tek bir metin var ise o satırı bulmaya yarayacak. o kullanılabilir.
 
veri alınacak dosyalardan bir kaç tanesini temsili veriler ile buraya eklerseniz biz de fikir yürütebiliriz belki...
 
yine formülleri ve bağlantıları ile bir dosya yükledim tüm dosyalar baştan sonra aynı


hatada dediğiniz gibi 49 dan sonra veri sıralaması olmadı durdu ama hatada vermedi

atlama yaptığını dosya adınında bir bağlantı olmasından anladım bağlantıları güncelle diyince sadece ilk satırda çıktı ( belki aslında bir sorun yoktu ama kod bağlantıyı sıraladığından farklıymış gibi göründü olabilir)

yardımınız için teşekkürler hafta başına analiz edip göndermem lazım
 

Ekli dosyalar

dosya bomboş. haliyle bana hiç bir şey ifade etmedi. buradan bir şey çıkaramam.

tüm dosyalardan 9 ve 49u yukarıda eklediğim kodlar yapıyor.

bunun dışında bir durum var ise açıklanması lazımdı.

hafta başına kadar şehir dışında olacağımdan tekrar bakma imkanım olmaz.

belki bir üye ne olduğunu anlar ve yardımcı olur.

kolay gelsin.
 
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub Klasordeki_Dosyalardan_Verileri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet
    Dim Klasor As Object, Yol As String, Satir As Long
    Dim Dosya As String, K2 As Workbook, S2 As Worksheet
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    S1.Cells.ClearContents
    Satir = 1
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbExclamation
        Exit Sub
    End If
    
    Yol = Klasor.Self.Path
    Dosya = Dir(Yol & "\*.xls")
    
    Application.ScreenUpdating = False
    
    While Dosya <> "" And Dosya <> K1.Name
        DoEvents
        Set K2 = Workbooks.Open(Yol & "\" & Dosya, False, False)
        Set S2 = K2.Sheets("Sheet1")
        S2.Rows("9:9").Copy
        S1.Cells(Satir, 1).PasteSpecial xlPasteValues
        S1.Cells(Satir, 1).PasteSpecial xlPasteFormats
        Satir = Satir + 1
        S2.Rows("49:49").Copy
        S1.Cells(Satir, 1).PasteSpecial xlPasteValues
        S1.Cells(Satir, 1).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        K2.Close False
        Dosya = Dir
        Satir = Satir + 1
    Wend

    S1.Cells.EntireColumn.AutoFit
    S1.Range("A1").Select
    
    Application.ScreenUpdating = True

    Set K1 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set Klasor = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan bey sonuç süper sizlere teşekkür ediyorum

umarım benzer durumlarda diğer arkadaşlarında işine yarar.

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