Sayfadaki Verileri İlgili Dosyalara Aktar

B

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Altın Üyelik Bitiş Tarihi
20-02-2025
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

Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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
 
B

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Altın Üyelik Bitiş Tarihi
20-02-2025
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
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
İyi çalışmalar.
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
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.
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
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
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Hata olmaması lazım.
Dosyanızı yollayın bakayım.
email adresim aşağıdaki imzamdadır.
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
Orion1' Alıntı:
Hata olmaması lazım.
Dosyanızı yollayın bakayım.
email adresim aşağıdaki imzamdadır.
Genişletmek için tıkla ...
Sy. Orion1 ;
mail adresinize tek dosyası excel olarak gönderilmiştir. Teşekkür ederim.
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Yolladığınız dosyadaki kodlar bana ait değil.
Kodları yazana yaptırmanız daha doğru olacaktır.
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
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.
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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.
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
Orion1' Alıntı:
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.
Genişletmek için tıkla ...
Sy. Orion1 ;
size göndermiş olduğum mail' e cevap gelmedi orada düzeltme yapmışmıydınız.
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
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.
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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?
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
Sy. Orion1 ;

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

Ekli dosyalar

Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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
 
50ersin

50ersin

Altın Üye
Katılım
13 Eylül 2012
Mesajlar
97
Excel Vers. ve Dili
2007 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2024
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

Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

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