• DİKKAT

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

Makro Koşullu Satır Çekme

F

Fuatckmk

Altın Üye
Katılım
21 Aralık 2017
Mesajlar
84
Excel Vers. ve Dili
Excel 365 - Türkçe
Arkadaşlar merhaba,

Makro oluşturdum fakat koşullu çekme konusunda istediğimi başaramadım.

Sayfa 1 de veriler mevcut. Verileri B kolonundaki isimlere göre sayfalara ayırıyor. Burada tek koşul J kolonu 1 var ise almamalı ve sayfa da oluşturmamalı.

Yani Ahmet'in J kolonunda 1 var ise es geç. Fakat şöyle bir ayrıntı var;

Ahmet'in J kolonunda hem 1 hem 2 hem 3 olabilir. Eğer böyleyse sadece 2 ve 3 leri almalı.

Ahmet'in J kolonunda sadece 1 var ise o zaman hiçbirşey oluşturmamalı.

Tek koşul bu

Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
On Error Resume Next
SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Sayfalara_Böl()
Application.ScreenUpdating = False
Dim S1 As Worksheet
Set S1 = Sheets("Data")
Dim Sayfa As String

For a = 2 To S1.Cells(Rows.Count, "B").End(3).Row
Sayfa = S1.Cells(a, "B")
If Not SayfaVarMi(Sayfa) Then
Sheets.Add
ActiveSheet.Name = Sayfa
Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
S1.Range("B1:V1").Copy Range("A1")

End If
sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
S1.Range(S1.Cells(a, "B"), S1.Cells(a, "V")).Copy _
Sheets(Sayfa).Cells(sonsatır, "A")
Next a
Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub
 
For satırından sonra aşağıdaki satırı:

Kod: 
If S1.cells(a,"J") <> 1 then

satırını ve Next satırından önce de

Kod: 
End If

Satırını ilave ederek deneyiniz.
 
YUSUF44' Alıntı:
For satırından sonra aşağıdaki satırı:

Kod: 
If S1.cells(a,"J") <> 1 then

satırını ve Next satırından önce de

Kod: 
End If

Satırını ilave ederek deneyiniz.
Genişletmek için tıkla ...

Yusuf Bey, teşekkür ederim tam istediğim gibi oldu :)

Ek olarak ayırdığı sayfaların en alt satırına bir boşluk bırakarak;

U kolonuna "Toplam" ... V kolonuna v kolonunun Toplamını alması bir alt satıra,
U kolonuna "Kdv" .... V kolonuna aldığı toplamın Kdv'sini alması bir alt satıra da,
U kolonuna "Genel Toplam" .... V kolonuna Toplam + Kdv = yapması mümkün mü?
 
Son düzenleme:
Next satırından sonra aşağıdaki satırları ilave edin. Eğer arada boşluk bırakmazsa a+1 vs'leri 1 arttırın (a+2, a+3, a+4 gibi)

Kod: 
S1.Cells(a+1,"U") = "Toplam"
S1.Cells(a+1,"V") = WorkheetFunction.Sum(Range("A2:A" & a))
S1.Cells(a+2,"U") = "KDV"
S1.Cells(a+2,"V") = Cells(a+1, "V") * 0.18
S1.Cells(a+3,"U") = "Genel Toplam"
S1.Cells(a+3,"V") = Cells(a+1, "V") + Cells(a+2, "V")
 
YUSUF44' Alıntı:
Next satırından sonra aşağıdaki satırları ilave edin. Eğer arada boşluk bırakmazsa a+1 vs'leri 1 arttırın (a+2, a+3, a+4 gibi)

Kod: 
S1.Cells(a+1,"U") = "Toplam"
[COLOR="Red"][B]S1.Cells(a+1,"V") = WorkheetFunction.Sum(Range("A2:A" & a))[/B][/COLOR]
S1.Cells(a+2,"U") = "KDV"
S1.Cells(a+2,"V") = Cells(a+1, "V") * 0.18
S1.Cells(a+3,"U") = "Genel Toplam"
S1.Cells(a+3,"V") = Cells(a+1, "V") + Cells(a+2, "V")
Genişletmek için tıkla ...

Kırmızı olarak işaretlediğim kısmı sarıya boyadı ve makro durdu.
Bu işlemi ayırdığı sayfalarda yapacak değil mi? Yanlış aktarmış olabilirim.
 
Workheet yazısında S harfi eksikmiş şimdi farkettim düzelttim toplam aldığı kolonu da V olarak revize ettim şuan işlemi yapıyor fakat Data sayfasında yapıyor onu ayırdığı sayfalarda yapması gerekiyor

Kod: 
S1.Cells(a + 1, "U") = "Toplam"
S1.Cells(a + 1, "V") = WorksheetFunction.Sum(Range("V2:V" & a))
S1.Cells(a + 2, "U") = "KDV"
S1.Cells(a + 2, "V") = Cells(a + 1, "V") * 0.18
S1.Cells(a + 3, "U") = "Genel Toplam"
S1.Cells(a + 3, "V") = Cells(a + 1, "V") + Cells(a + 2, "V")
 
Aşağıdaki gibi deneyin. Eğer doğru sonuç vermezse örnek dosya paylaşın:

Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
On Error Resume Next
SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Sayfalara_Böl()
Application.ScreenUpdating = False
Dim S1 As Worksheet
Set S1 = Sheets("Data")
Dim Sayfa As String

For a = 2 To S1.Cells(Rows.Count, "B").End(3).Row
If S1.Cells(a, "J") <> 1 Then

Sayfa = S1.Cells(a, "B")
If Not SayfaVarMi(Sayfa) Then
Sheets.Add
ActiveSheet.Name = Sayfa
Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
S1.Range("B1:V1").Copy Range("A1")

End If
sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
S1.Range(S1.Cells(a, "B"), S1.Cells(a, "V")).Copy _
Sheets(Sayfa).Cells(sonsatır, "A")
End If

Sheets(Sayfa).Cells(sonsatır + 1, "U") = "Toplam"
Sheets(Sayfa).Cells(sonsatır + 1, "V") = WorkheetFunction.Sum(Sheets(Sayfa).Range("A2:A" & a))
Sheets(Sayfa).Cells(sonsatır + 2, "U") = "KDV"
Sheets(Sayfa).Cells(sonsatır + 2, "V") = WorkheetFunction.Round(Sheets(Sayfa).Cells(a + 1, "V") * 0.18, 2)
Sheets(Sayfa).Cells(sonsatır + 3, "U") = "Genel Toplam"
Sheets(Sayfa).Cells(sonsatır + 3, "V") = Sheets(Sayfa).Cells(a + 1, "V") + Sheets(Sayfa).Cells(a + 2, "V")

Next a
Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub
 
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin. Eğer doğru sonuç vermezse örnek dosya paylaşın:

Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
On Error Resume Next
SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Sayfalara_Böl()
Application.ScreenUpdating = False
Dim S1 As Worksheet
Set S1 = Sheets("Data")
Dim Sayfa As String

For a = 2 To S1.Cells(Rows.Count, "B").End(3).Row
If S1.Cells(a, "J") <> 1 Then

Sayfa = S1.Cells(a, "B")
If Not SayfaVarMi(Sayfa) Then
Sheets.Add
ActiveSheet.Name = Sayfa
Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
S1.Range("B1:V1").Copy Range("A1")

End If
sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
S1.Range(S1.Cells(a, "B"), S1.Cells(a, "V")).Copy _
Sheets(Sayfa).Cells(sonsatır, "A")
End If

Sheets(Sayfa).Cells(sonsatır + 1, "U") = "Toplam"
Sheets(Sayfa).Cells(sonsatır + 1, "V") = WorkheetFunction.Sum(Sheets(Sayfa).Range("A2:A" & a))
Sheets(Sayfa).Cells(sonsatır + 2, "U") = "KDV"
Sheets(Sayfa).Cells(sonsatır + 2, "V") = WorkheetFunction.Round(Sheets(Sayfa).Cells(a + 1, "V") * 0.18, 2)
Sheets(Sayfa).Cells(sonsatır + 3, "U") = "Genel Toplam"
Sheets(Sayfa).Cells(sonsatır + 3, "V") = Sheets(Sayfa).Cells(a + 1, "V") + Sheets(Sayfa).Cells(a + 2, "V")

Next a
Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub
Genişletmek için tıkla ...

Yusuf bey,

ekteki dosyaya göre birkaç harf değişikliği yapıp uyarladım fakat çalıştırdığımda ilk sayfalar doğru diğer sayfalar yanlış sonuç çıkıyor birde boşluk bırakarak yapmayı uyarlayamadım
 
Son düzenleme:
Aşağıdaki gibi daha iyi oldu galiba:

Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
On Error Resume Next
SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Sayfalara_Böl()
Application.ScreenUpdating = False
Dim S1 As Worksheet
Set S1 = Sheets("Data")
Dim Sayfa As String
son = S1.Cells(Rows.Count, "B").End(3).Row
For a = 2 To son
    If S1.Cells(a, "J") <> 1 Then
        Sayfa = S1.Cells(a, "B")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add
            ActiveSheet.Name = Sayfa
            Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
            S1.Range("B1:V1").Copy Range("A1")
        End If
        sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
        S1.Range(S1.Cells(a, "B"), S1.Cells(a, "V")).Copy Sheets(Sayfa).Cells(sonsatır, "A")
    End If

Next a

For b = 2 To Sheets.Count
    sonsatır = Sheets(b).Cells(Rows.Count, "U").End(3).Row
    Sheets(b).Cells(sonsatır + 2, "T") = "Toplam"
    Sheets(b).Cells(sonsatır + 2, "U").FormulaR1C1 = "=SUM(R2C21:R[-2]C)"
    
    Sheets(b).Cells(sonsatır + 3, "T") = "KDV"
    Sheets(b).Cells(sonsatır + 3, "U").FormulaR1C1 = "=ROUND(R[-1]C*18%,2)"
    
    Sheets(b).Cells(sonsatır + 4, "T") = "Genel Toplam"
    Sheets(b).Cells(sonsatır + 4, "U").FormulaR1C1 = "=R[-2]C+R[-1]C"
    
    Sheets(b).Range("T" & sonsatır + 2 & ":U" & sonsatır + 4).Font.Bold = True
    Sheets(b).Range("T" & sonsatır + 2 & ":U" & sonsatır + 4).Borders.LineStyle = xlContinuous
    Sheets(b).Range("U" & sonsatır + 2 & ":U" & sonsatır + 4).NumberFormat = "#,##0.00 $"
    Sheets(b).Columns.AutoFit
Next

Application.ScreenUpdating = True
MsgBox " B i t t i "

End Sub
 
YUSUF44' Alıntı:
Aşağıdaki gibi daha iyi oldu galiba:

Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
On Error Resume Next
SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Sayfalara_Böl()
Application.ScreenUpdating = False
Dim S1 As Worksheet
Set S1 = Sheets("Data")
Dim Sayfa As String
son = S1.Cells(Rows.Count, "B").End(3).Row
For a = 2 To son
    If S1.Cells(a, "J") <> 1 Then
        Sayfa = S1.Cells(a, "B")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add
            ActiveSheet.Name = Sayfa
            Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
            S1.Range("B1:V1").Copy Range("A1")
        End If
        sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
        S1.Range(S1.Cells(a, "B"), S1.Cells(a, "V")).Copy Sheets(Sayfa).Cells(sonsatır, "A")
    End If

Next a

For b = 2 To Sheets.Count
    sonsatır = Sheets(b).Cells(Rows.Count, "U").End(3).Row
    Sheets(b).Cells(sonsatır + 2, "T") = "Toplam"
    Sheets(b).Cells(sonsatır + 2, "U").FormulaR1C1 = "=SUM(R2C21:R[-2]C)"
    
    Sheets(b).Cells(sonsatır + 3, "T") = "KDV"
    Sheets(b).Cells(sonsatır + 3, "U").FormulaR1C1 = "=ROUND(R[-1]C*18%,2)"
    
    Sheets(b).Cells(sonsatır + 4, "T") = "Genel Toplam"
    Sheets(b).Cells(sonsatır + 4, "U").FormulaR1C1 = "=R[-2]C+R[-1]C"
    
    Sheets(b).Range("T" & sonsatır + 2 & ":U" & sonsatır + 4).Font.Bold = True
    Sheets(b).Range("T" & sonsatır + 2 & ":U" & sonsatır + 4).Borders.LineStyle = xlContinuous
    Sheets(b).Range("U" & sonsatır + 2 & ":U" & sonsatır + 4).NumberFormat = "#,##0.00 $"
    Sheets(b).Columns.AutoFit
Next

Application.ScreenUpdating = True
MsgBox " B i t t i "

End Sub
Genişletmek için tıkla ...

Yusuf Bey,

istediğimden de güzel oldu çok teşekkürler emeğinize sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst