Şarta bağlı olarak satır kopyalama (Sütun değerine göre)

[uhercan]

Merhaba,

Bahsettiğiniz şekilde dış dosyaya aktarım yapılabilir. Fakat FİRMA ADI dediğiniz bölümle dış dosyanın adı aynı olmalıdır. Dış dosyalarınız asıl dosyanızla aynı klasörde mi bulunuyor?

Ayrıca aktarım yapılırken dış dosyada bulunan kayıtlar silinecek mi? Yoksa eski kayıtların altına mı aktarım yapılacak?

öncelikle ilginize ve kısa sürede geri dönüşünüz için teşekkür ederim.
evet aynı klasör içinde olacaklar.
şahısaktar deyince hepsini yeniden aktarabilir. çünkü eski tarihli kayıtlarda değişiklik yapılabiliyor

 

[Korhan Ayhan]

Anladım..

Firma isimleriniz nasıl olacak?

 

[uhercan]

Anladım..

Firma isimleriniz nasıl olacak?

FİRMA
ÖZGEYİKÇİ	B
CLS-3	C

bu alana eklediklerimi yada düzeltmelerimi macro otomatik atsın. klasör içinde ki dosya sekmeleri ben aktarım yapmadan oluştururum

 

[Korhan Ayhan]

Deneyiniz.

Klasördeki eski dosyayı silerek aktarım yapıyor. Bu sebeple verilerinizi YEDEKLEYEREK deneyiniz.

 

[uhercan]

Deneyiniz.

Klasördeki eski dosyayı silerek aktarım yapıyor. Bu sebeple verilerinizi YEDEKLEYEREK deneyiniz.

elinize sağlık.
yalnız genel sekmesinde firma kodlaını değiştirince dosyaları siliyor. dosyaları silme yerine içindeki bilgileri temizleyerek yniden aktara bilirmi;*

 

[Korhan Ayhan]

Eski bilgiler değişiyor dediğiniz için silme yöntemini tercih ettim.

Firma kodlarını değiştirdiğinizde eski dosya ismi eşleşmezse silme işlemi yapmaz.

 

[uhercan]

Eski bilgiler değişiyor dediğiniz için silme yöntemini tercih ettim.

Firma kodlarını değiştirdiğinizde eski dosya ismi eşleşmezse silme işlemi yapmaz.

bu şekilde kullanayım sorun olursa direk mesaj atabilirmiyim?
tekrar elinize sağlık teşekkür ederim

 

[Korhan Ayhan]

Bir sorun olursa bu başlık altında yardım talebinde bulunabilirsiniz.

 

[uhercan]

Bir sorun olursa bu başlık altında yardım talebinde bulunabilirsiniz.

kolay gelsin
şimdi deneme yaparken dikkatimi çekti.
aktarılan dosyada çalışma için oluşturduğum yeni sekmeleride aktarma sırasında siliyor. aktarılan yere sadece copy paste yapabilirmi diğer sekmeleri silmeden

 

[Korhan Ayhan]

Doğrudur. Eski dosya tamamen silinip yeniden oluşturuluyor.

Detay vermediğiniz için kurguyu bu şekilde tasarlamıştım...

 

[uhercan]

Doğrudur. Eski dosya tamamen silinip yeniden oluşturuluyor.

Detay vermediğiniz için kurguyu bu şekilde tasarlamıştım...

haklısınız.kusura bakmayın.peki bunu düzeltme şansımız varmı?

 

[Korhan Ayhan]

Aktarım yapılacak dosyada verilerin aktarılacağı sayfanın adının Ekstre olduğunu varsaydım.

Deneyiniz.

Option Explicit

Sub Export_Data()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WB As Workbook
    Dim File_Path As String, Company As Range, File_Name As String
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.EnableEvents = 0
    
    Set S1 = Sheets("GENEL")
    Set S2 = Sheets("Ekstre")
    Set S3 = Sheets("DATA")
    
    S1.Cells.Interior.ColorIndex = xlColorIndexNone
    
    File_Path = ThisWorkbook.Path & Application.PathSeparator
    
    For Each Company In S3.Range("A6:B" & S3.Cells(S3.Rows.Count, 1).End(3).Row)
        If WorksheetFunction.CountIf(S1.Range("B:B"), Company.Offset(, 1).Value) > 0 Then
            File_Name = File_Path & Company.Value & ".xlsm"
            If Dir(File_Name) <> "" Then
                Set WB = Workbooks.Open(File_Name)
                S1.Range("A2:AF8501").AutoFilter Field:=2, Criteria1:=Company.Offset(, 1).Value
                S1.Range("B3:AF8501").SpecialCells(xlCellTypeVisible).Copy WB.Sheets("Ekstre").Range("B3")
                WB.Close True
                Set WB = Nothing
            Else
                S1.Range("A2:AF8501").AutoFilter Field:=2, Criteria1:=Company.Offset(, 1).Value
                S1.Range("B3:AF8501").SpecialCells(xlCellTypeVisible).Copy S2.Range("B3")
                S2.Copy
                ActiveWorkbook.SaveAs File_Name, 52
                ActiveWorkbook.Close
            End If
        End If
    Next

    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0

    Application.EnableEvents = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub

 

[uhercan]

Aktarım yapılacak dosyada verilerin aktarılacağı sayfanın adının Ekstre olduğunu varsaydım.

Deneyiniz.

Option Explicit

Sub Export_Data()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WB As Workbook
    Dim File_Path As String, Company As Range, File_Name As String
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.EnableEvents = 0
   
    Set S1 = Sheets("GENEL")
    Set S2 = Sheets("Ekstre")
    Set S3 = Sheets("DATA")
   
    S1.Cells.Interior.ColorIndex = xlColorIndexNone
   
    File_Path = ThisWorkbook.Path & Application.PathSeparator
   
    For Each Company In S3.Range("A6:B" & S3.Cells(S3.Rows.Count, 1).End(3).Row)
        If WorksheetFunction.CountIf(S1.Range("B:B"), Company.Offset(, 1).Value) > 0 Then
            File_Name = File_Path & Company.Value & ".xlsm"
            If Dir(File_Name) <> "" Then
                Set WB = Workbooks.Open(File_Name)
                S1.Range("A2:AF8501").AutoFilter Field:=2, Criteria1:=Company.Offset(, 1).Value
                S1.Range("B3:AF8501").SpecialCells(xlCellTypeVisible).Copy WB.Sheets("Ekstre").Range("B3")
                WB.Close True
                Set WB = Nothing
            Else
                S1.Range("A2:AF8501").AutoFilter Field:=2, Criteria1:=Company.Offset(, 1).Value
                S1.Range("B3:AF8501").SpecialCells(xlCellTypeVisible).Copy S2.Range("B3")
                S2.Copy
                ActiveWorkbook.SaveAs File_Name, 52
                ActiveWorkbook.Close
            End If
        End If
    Next

    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0

    Application.EnableEvents = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
   
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub

ÇOK TEŞEKKÜR EDERİM SÜPER OLMUŞ

 

[uhercan]

Merhaba,

Bahsettiğiniz şekilde dış dosyaya aktarım yapılabilir. Fakat FİRMA ADI dediğiniz bölümle dış dosyanın adı aynı olmalıdır. Dış dosyalarınız asıl dosyanızla aynı klasörde mi bulunuyor?

Ayrıca aktarım yapılırken dış dosyada bulunan kayıtlar silinecek mi? Yoksa eski kayıtların altına mı aktarım yapılacak?

Merhaba kolay gelsin,
bazı sütünları kilitleyip kaydettiğimde macro hata veriyor bunu nasıl gideririz?


NOT
hata mesajı
S1.Range("A2:AF8501").AutoFilter Field:=2, Criteria1:=Company.Offset(, 1).Value

 

[Korhan Ayhan]

Sayfa korumalı olunca makro doğal olarak hata verecektir.

Kod çalışmadan önce koruma kaldırılmalı, sonrasında tekrar koruma eklenmelidir.

Forumda Unprotect ve Protect ifadeleri ile arama yaparsanız benzer kod örneklerine ulaşabilirsiniz.

 

[uhercan]

Sayfa korumalı olunca makro doğal olarak hata verecektir.

Kod çalışmadan önce koruma kaldırılmalı, sonrasında tekrar koruma eklenmelidir.

Forumda Unprotect ve Protect ifadeleri ile arama yaparsanız benzer kod örneklerine ulaşabilirsiniz.

ok teşekkür ederim.
iyi çalışmalar

 

[mühendisberke]

ORNEK_56_-SARTA_BAGLI_OLARAK_SATIR_KOPYALAMA.xlsm dosyasını indir - download

ORNEK_56_-SARTA_BAGLI_OLARAK_SATIR_KOPYALAMA.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

hangi sayfa yapılacaksa o sayfa seçilir
makro 1 kopya sayfasına a1'den başlayarak kopyalanacak satırları yazar
makro 2 kopya sayfasını sıfırlar

Dipnot: Siyah sarı tasarım çok güzel

 

[mühendisberke]

Veriler büyük olduğunda bütün uygun satırları tek seferde kopyalamak ve sonra tek bir yapıştırma işlemi yapmak daha kısa sürer diye düşündüm.

10000 satırda toplu kopyalamak sorun yaratır. benzer büyüklükle çalışırken ayrıca
Application.RecentFiles.Maximum = 0
Sleep (100)
kullanmanızı öneririm cache doldukça ve işlem sayısı arttıkça değerler birbirine girer(umarım yaşamazsınız)

Dipnot: sleep için Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) yazılıyor modül tepesine. Mac'lerde nasıl bilmiyorum.

 

[mühendisberke]

yardımcı olan varsa sevinirim.

Standart model zaten D aratıp tablonun köşesini buluyor sonra son satırda eşleneni buluyor.
Burada sadece a ve b harfleri var ve dediğin kadar çeşitlilik yok son satırda.
Ben do while ile çözdüm G'ye gelince duracak şekilde.

ORNEK_56_-SARTA_BAGLI_OLARAK_SATIR_KOPYALAMA_2.xlsm dosyasını indir - download

ORNEK_56_-SARTA_BAGLI_OLARAK_SATIR_KOPYALAMA_2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

Ama senin için özel bir dosya hazırladım umarım beğenirsin.
Hepsini bul 3 farklı değere göre atama yapıyor.
Hepsini Temizle atama sayfalarını sıfırlıyor
2 deneme sayfası var.
Temizleye basınca hepsini temizliyor.
Bozuk verilerle işlem için denedim eğlenceli oldu.

 

[uhercan]

ok teşekkür ederim.
iyi çalışmalar

tekrar merhaba dosyalar bilgiyarımda sorunsuz çalışıyor Ancak başka bilgisayarda çalışmıyor. (tüm dosyalar aynı klasör altında)

macro hata mesajı altta

If Dir(File_Name) <> "" Then