• DİKKAT

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

Sayfadaki Verileri İlgili Dosyalara Aktar

B

baydeniro

Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Merhaba Arkadaşlar,
N2:N5 hücrelerinde bulunan verilere ayrı Excel dosyaları oluşturup, A:B sütunlarında bulunan verileri ilgili oldukları dosyalara kaydetmek mümkün mü ?

229090
 

Ekli dosyalar

Buyurun.
Dosyalar dosyanızın bulunduğu klasöre çıkarılıyor.

Kod: 
Sub dosyalara_aktar()
Dim wb As Workbook, i As Long, sonsat As Long, sh As Worksheet, j As Byte, k As Range
Dim sonsat2 As Long, adr As String
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For j = 2 To 5
    If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("DATA").Cells(j, "N").Value & ".xlsx") = "" Then
        Set wb = Workbooks.Add
        wb.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Data").Cells(j, "N").Value & ".xlsx"
        wb.Close
    End If
Next j
For j = 2 To 5
    Workbooks.Open ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("DATA").Cells(j, "N").Value & ".xlsx"
    Set wb = ActiveWorkbook
    sonsat2 = wb.Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1
    Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).Find(ThisWorkbook.Sheets("DATA").Cells(j, "N").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            wb.Sheets("Sayfa1").Cells(sonsat2, "A").Value = k.Value
            wb.Sheets("Sayfa1").Cells(sonsat2, "B").Value = k.Offset(0, 1).Value
            Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).FindNext(k)
            sonsat2 = sonsat2 + 1
        Loop While Not k Is Nothing And k.Address <> adr
    End If
    sonsat2 = 0
    wb.Close True
Next
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı"
End Sub
 
Orion1' Alıntı:
Buyurun.
Dosyalar dosyanızın bulunduğu klasöre çıkarılıyor.

Kod: 
Sub dosyalara_aktar()
Dim wb As Workbook, i As Long, sonsat As Long, sh As Worksheet, j As Byte, k As Range
Dim sonsat2 As Long, adr As String
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For j = 2 To 5
    If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("DATA").Cells(j, "N").Value & ".xlsx") = "" Then
        Set wb = Workbooks.Add
        wb.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Data").Cells(j, "N").Value & ".xlsx"
        wb.Close
    End If
Next j
For j = 2 To 5
    Workbooks.Open ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("DATA").Cells(j, "N").Value & ".xlsx"
    Set wb = ActiveWorkbook
    sonsat2 = wb.Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1
    Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).Find(ThisWorkbook.Sheets("DATA").Cells(j, "N").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            wb.Sheets("Sayfa1").Cells(sonsat2, "A").Value = k.Value
            wb.Sheets("Sayfa1").Cells(sonsat2, "B").Value = k.Offset(0, 1).Value
            Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).FindNext(k)
            sonsat2 = sonsat2 + 1
        Loop While Not k Is Nothing And k.Address <> adr
    End If
    sonsat2 = 0
    wb.Close True
Next
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı"
End Sub
Genişletmek için tıkla ...
Orion1 üstadım mükemmel olmuş. Elinize aklınıza sağlık. çok teşekkür ederim, sağlıcakla kalın
 
İyi çalışmalar.
 
Sy. Orion1 ;
Orion1' Alıntı:
Buyurun.
Dosyalar dosyanızın bulunduğu klasöre çıkarılıyor.

Kod: 
Sub dosyalara_aktar()
Dim wb As Workbook, i As Long, sonsat As Long, sh As Worksheet, j As Byte, k As Range
Dim sonsat2 As Long, adr As String
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For j = 2 To 5
    If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("DATA").Cells(j, "N").Value & ".xlsx") = "" Then
        Set wb = Workbooks.Add
        wb.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Data").Cells(j, "N").Value & ".xlsx"
        wb.Close
    End If
Next j
For j = 2 To 5
    Workbooks.Open ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("DATA").Cells(j, "N").Value & ".xlsx"
    Set wb = ActiveWorkbook
    sonsat2 = wb.Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1
    Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).Find(ThisWorkbook.Sheets("DATA").Cells(j, "N").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            wb.Sheets("Sayfa1").Cells(sonsat2, "A").Value = k.Value
            wb.Sheets("Sayfa1").Cells(sonsat2, "B").Value = k.Offset(0, 1).Value
            Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).FindNext(k)
            sonsat2 = sonsat2 + 1
        Loop While Not k Is Nothing And k.Address <> adr
    End If
    sonsat2 = 0
    wb.Close True
Next
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı"
End Sub
Genişletmek için tıkla ...


Sy. Orion1 ;

benim dosyama uygulamaya çalışıyorum A sütunu ile N sütunu arasında ki verileri aktarmak istiyorum ama bir türlü olmuyor yardımcı olur musunuz. teşekkür ederim.
 
Buyurun.
C sütunu için ben yaptım.Kırmızı satır.N sütununa kadarda siz yapınız.
Rich (BB code): 
Do
            wb.Sheets("Sayfa1").Cells(sonsat2, "A").Value = k.Value
            wb.Sheets("Sayfa1").Cells(sonsat2, "B").Value = k.Offset(0, 1).Value
            wb.Sheets("Sayfa1").Cells(sonsat2, "C").Value = k.Offset(0, 2).Value
            Set k = ThisWorkbook.Sheets("DATA").Range("A2:A" & sonsat).FindNext(k)
            sonsat2 = sonsat2 + 1
        Loop While Not k Is Nothing And k.Address <> adr
 
Sy. Orion1 ;
Bu şekilde hata alıyorum birde T sütunu koşulu olmadan sadece sayfa1 de belirlenen sütunları aktarsa olmaz mı ? Safya1 Komple Formüllü yalınız onun bir sakıncası olur mu ? Teşekkür ederim.

229229
 
Hata olmaması lazım.
Dosyanızı yollayın bakayım.
email adresim aşağıdaki imzamdadır.
 
Yolladığınız dosyadaki kodlar bana ait değil.
Kodları yazana yaptırmanız daha doğru olacaktır.
 
Orion1' Alıntı:
Yolladığınız dosyadaki kodlar bana ait değil.
Kodları yazana yaptırmanız daha doğru olacaktır.
Genişletmek için tıkla ...

Sy. Orion1 ;
kodları korhan ayhan beyden ve formda ki diğer uzmanlardan parça parça topladım herkese ayrı ayrı mail atmak pek doğru olmaz sanırım yardımcı olursanız sevinirim yok işleriniz yoğun ilgilenemem diyorsanız yine de teşekkür ederim.
 
Ben kim yaptıysa o daha iyi bilir ne yaptığını demek istemiştim.
Ben size kod yazmıştım ve doğru çalışıyordu.
 
Sy. Orion1 ;
Size zahmet olmazsa sadece size ait olan kodu düzelte bilir misiniz . Ama sayfa1 de şart aramadan B,C,D,F,G,H,I,J,K,L,M Sütunlarını farklı kayıt etsin.
 
50ersin' Alıntı:
Sy. Orion1 ;
Size zahmet olmazsa sadece size ait olan kodu düzelte bilir misiniz . Ama sayfa1 de şart aramadan B,C,D,F,G,H,I,J,K,L,M Sütunlarını farklı kayıt etsin.
Genişletmek için tıkla ...
Farklı derken neyi kastettiniz?
 
Sy. Orion1 ;

size zahmet bir adet dosya yükledim orada açıklama yaptım yardımcı olur musunuz. Teşekkür ederim.
 

Ekli dosyalar

Buyurun.
Kod: 
Sub dosyalara_aktar()
Dim wb As Workbook, i As Long, sonsat As Long, sh As Worksheet, j As Byte, k As Range
Dim sonsat2 As Long, adr As String, ad As String
sonsat = Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
ad = Format(Now, "dd_mm_yyyy_hh_mm_ss")
If Dir(ThisWorkbook.Path & "\" & Format(ad, "dd_mm_yyyy_hh_mm_ss") & ".xlsx") = "" Then
    Set wb = Workbooks.Add
    wb.SaveAs ThisWorkbook.Path & "\" & Format(ad, "dd_mm_yyyy_hh_mm_ss") & ".xlsx"
    wb.Close
End If
    Workbooks.Open ThisWorkbook.Path & "\" & Format(ad, "dd_mm_yyyy_hh_mm_ss") & ".xlsx"
    Set wb = ActiveWorkbook
    sonsat2 = wb.Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1
    ThisWorkbook.Sheets("Sayfa1").Range("A1:D" & sonsat).Copy
        wb.Sheets("Sayfa1").Range("B" & sonsat2).PasteSpecial
    ThisWorkbook.Sheets("Sayfa1").Range("F1:F" & sonsat).Copy
        wb.Sheets("Sayfa1").Range("E" & sonsat2).PasteSpecial
    ThisWorkbook.Sheets("Sayfa1").Range("B1:F" & sonsat).Copy
        wb.Sheets("Sayfa1").Range("F" & sonsat2).PasteSpecial
    ThisWorkbook.Sheets("Sayfa1").Range("B1:C" & sonsat).Copy
             wb.Sheets("Sayfa1").Range("L" & sonsat2).PasteSpecial
    Application.CutCopyMode = False
    
    sonsat2 = sonsat2 + 1
    sonsat2 = 0
    wb.Close True
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı"
End Sub
 
Orion1' Alıntı:
Buyurun.
Kod: 
Sub dosyalara_aktar()
Dim wb As Workbook, i As Long, sonsat As Long, sh As Worksheet, j As Byte, k As Range
Dim sonsat2 As Long, adr As String, ad As String
sonsat = Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
ad = Format(Now, "dd_mm_yyyy_hh_mm_ss")
If Dir(ThisWorkbook.Path & "\" & Format(ad, "dd_mm_yyyy_hh_mm_ss") & ".xlsx") = "" Then
    Set wb = Workbooks.Add
    wb.SaveAs ThisWorkbook.Path & "\" & Format(ad, "dd_mm_yyyy_hh_mm_ss") & ".xlsx"
    wb.Close
End If
    Workbooks.Open ThisWorkbook.Path & "\" & Format(ad, "dd_mm_yyyy_hh_mm_ss") & ".xlsx"
    Set wb = ActiveWorkbook
    sonsat2 = wb.Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1
    ThisWorkbook.Sheets("Sayfa1").Range("A1:D" & sonsat).Copy
        wb.Sheets("Sayfa1").Range("B" & sonsat2).PasteSpecial
    ThisWorkbook.Sheets("Sayfa1").Range("F1:F" & sonsat).Copy
        wb.Sheets("Sayfa1").Range("E" & sonsat2).PasteSpecial
    ThisWorkbook.Sheets("Sayfa1").Range("B1:F" & sonsat).Copy
        wb.Sheets("Sayfa1").Range("F" & sonsat2).PasteSpecial
    ThisWorkbook.Sheets("Sayfa1").Range("B1:C" & sonsat).Copy
             wb.Sheets("Sayfa1").Range("L" & sonsat2).PasteSpecial
    Application.CutCopyMode = False
   
    sonsat2 = sonsat2 + 1
    sonsat2 = 0
    wb.Close True
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı"
End Sub
Genişletmek için tıkla ...


Sy. Orion1 ;
aktarma yapıyor ama sütunları tekrarlıyor sizde bir kontrol eder misiniz. tekrar dosyamı ekledim sayfa2 de açıklamayı düzelttim
 

Ekli dosyalar

Son yolladığınız dosyadaki kodlar benim en son yazdığım kodlar değil.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst