Sayfada seçilen verileri farklı sayfaya kaydetme.

[Sinan2618]

Arkadaşlar merhaba,

Ekteki dosya içerisinde 3 Tane Buton yapıp bu butonlara aşağıdaki şekilde isim vereceğim.

Komisyon 1
Komisyon 2
Komisyon 3

Ben komisyon 1 butonuna tıkladığım zaman burada sütunda tanımlı olan verilerin (%0 olanlar Hariç) filtrelenerek sadece A,B,C,D,E,F,G,H,S ve X Sütunlarının seçilerek benim kod içerisine belirteceğim farklı bir dosya ismi ile kaydetmesini nasıl sağlarım.

Teşekkürler.

 

[askm]

Örnek dosyanıza 3 tane sayfa ekleyip,1. sayfaya 1. butonun yapmasını istediğiniz şekli, 2. sayfaya 2. butonun yapmasını istediğiniz şekli, 3. sayfaya da 3. butonun yapmasını istediğiniz son şekli eklerseniz. Ona göre o sayfaları şablon yapar, oraya veri gönderip, İlgili sayfayı kaydedebiliriz.

 

[Sinan2618]

Örnek dosyanıza 3 tane sayfa ekleyip,1. sayfaya 1. butonun yapmasını istediğiniz şekli, 2. sayfaya 2. butonun yapmasını istediğiniz şekli, 3. sayfaya da 3. butonun yapmasını istediğiniz son şekli eklerseniz. Ona göre o sayfaları şablon yapar, oraya veri gönderip, İlgili sayfayı kaydedebiliriz.

Merhaba,

Ekteki gibi olmasını istiyorum. Burdaki ekstra durum %0 olan komisyonların gelmemesi gerekiyor.

Teşekkürler.

 

[askm]

Komisyon 1 için aşağıdaki kodu kullanın. Diğerlerini de ona göre uyarlayabilirsiniz. Olmassa bakarız.

Sub askm_aynı_1()
Dim s1, s2 As Worksheet
Set s1 = Sheets("2017")
Set s2 = Sheets("Komisyon 1")
Application.Calculation = xlCalculationManual
SonSatir = s1.Cells(65536, 2).End(xlUp).Row
x = 1
s2.Cells.ClearContents
For i = 1 To SonSatir
    s2.Cells(x, "A") = s1.Cells(i, "A")
    s2.Cells(x, "B") = s1.Cells(i, "B")
    s2.Cells(x, "C") = s1.Cells(i, "C")
    s2.Cells(x, "D") = s1.Cells(i, "D")
    s2.Cells(x, "E") = s1.Cells(i, "E")
    s2.Cells(x, "F") = s1.Cells(i, "F")
    
    If s1.Cells(i, "G").Value <> 0 And s1.Cells(i, "G").Value <> "0%" Then
        s2.Cells(x, "G") = s1.Cells(i, "G")
    End If
    s2.Cells(x, "H") = s1.Cells(i, "H")
    
    s2.Cells(x, "I") = s1.Cells(i, "S")
    s2.Cells(x, "J") = s1.Cells(i, "X")
    
    x = x + 1
Next
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Sinan2618]

Komisyon 1 için aşağıdaki kodu kullanın. Diğerlerini de ona göre uyarlayabilirsiniz. Olmassa bakarız.

Sub askm_aynı_1()
Dim s1, s2 As Worksheet
Set s1 = Sheets("2017")
Set s2 = Sheets("Komisyon 1")
Application.Calculation = xlCalculationManual
SonSatir = s1.Cells(65536, 2).End(xlUp).Row
x = 1
s2.Cells.ClearContents
For i = 1 To SonSatir
    s2.Cells(x, "A") = s1.Cells(i, "A")
    s2.Cells(x, "B") = s1.Cells(i, "B")
    s2.Cells(x, "C") = s1.Cells(i, "C")
    s2.Cells(x, "D") = s1.Cells(i, "D")
    s2.Cells(x, "E") = s1.Cells(i, "E")
    s2.Cells(x, "F") = s1.Cells(i, "F")
    
    If s1.Cells(i, "G").Value <> 0 And s1.Cells(i, "G").Value <> "0%" Then
        s2.Cells(x, "G") = s1.Cells(i, "G")
    End If
    s2.Cells(x, "H") = s1.Cells(i, "H")
    
    s2.Cells(x, "I") = s1.Cells(i, "S")
    s2.Cells(x, "J") = s1.Cells(i, "X")
    
    x = x + 1
Next
Application.Calculation = xlCalculationAutomatic
End Sub

Merhaba kod işe yarıyor peki bu kodu farklı bir dosyaya kaydetmek için ne yapmak gerekir? Aynı excel içerisinde bir sayfa değilde farklı bir excel olarak.

 

[muygun]

Merhaba;
Alternatif olsun. İnceleyin.
İyi çalışmalar.

 

[Sinan2618]

Merhaba;
Alternatif olsun. İnceleyin.
İyi çalışmalar.

Nedenini çözemedim ama dosya bende çalışmıyor :S

 

[askm]

Kodlara ilave yaptım. Aşağıdaki şekilde deneyin.

Sub askm_aynı_1()
Dim s1, s2 As Worksheet
Set s1 = Sheets("2017")
Set s2 = Sheets("Komisyon 1")
Application.Calculation = xlCalculationManual
SonSatir = s1.Cells(65536, 2).End(xlUp).Row
x = 1
s2.Cells.ClearContents
For i = 1 To SonSatir
    s2.Cells(x, "A") = s1.Cells(i, "A")
    s2.Cells(x, "B") = s1.Cells(i, "B")
    s2.Cells(x, "C") = s1.Cells(i, "C")
    s2.Cells(x, "D") = s1.Cells(i, "D")
    s2.Cells(x, "E") = s1.Cells(i, "E")
    s2.Cells(x, "F") = s1.Cells(i, "F")
    
    If s1.Cells(i, "G").Value <> 0 And s1.Cells(i, "G").Value <> "0%" Then
        s2.Cells(x, "G") = s1.Cells(i, "G")
    End If
    s2.Cells(x, "H") = s1.Cells(i, "H")
    
    s2.Cells(x, "I") = s1.Cells(i, "S")
    s2.Cells(x, "J") = s1.Cells(i, "X")
    
    x = x + 1
Next
s2.Select
Application.DisplayAlerts = False

ActiveSheet.Copy
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"  'Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Name & ".xls"
.Close
End With
Application.Calculation = xlCalculationAutomatic
End Sub