Sayfa1'de belirlenen satır aralığı "0" dan büyükse, istenilen hücrelerin Sayfa2'ye kopyalanması

G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Elimdeki projede Sayfa1'de belirlemiş olduğum satır aralığı toplamı "0"dan büyükse aynı sayfada karar verdiğimiz hücrelerin Sayfa2'de ki yerlerine kopyalanması gerekiyor.
Kopyalama esnasında "0" değerleri kopyalanmamalı.
Biraz zor ve karmaşık bir durum. tam ustalık istiyor diye düşünüyorum. Bu adımda bittiğinde projem tamamlanmış olacak.
İşin üstadlarına şimdiden teşekkür ederim.
Bir örnek dosyam var.
 

Ekli dosyalar

Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Detaylı deneme yapmadım.
Kod: 
Private Sub CommandButton1_Click()

    Dim S1 As Worksheet, i As Byte, t1, t2, t3, s As Integer, j As Byte, sut As Byte
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    
    Range("B6:M" & Rows.Count).ClearContents

    For i = 6 To 30
    
        t1 = Application.Sum(S1.Range(S1.Cells(i, "J"), S1.Cells(i, "N")))
        t2 = Application.Sum(S1.Range(S1.Cells(i, "P"), S1.Cells(i, "T")))
        t3 = Application.Sum(S1.Range(S1.Cells(i, "V"), S1.Cells(i, "W")))
        
        If t1 > 0 Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 10 To 14 'J:N sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                    sut = sut + 1
                End If
            Next j
        End If
        
        If t2 > 0 Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 16 To 20 'P:T sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                    sut = sut + 1
                End If
            Next j
        End If
        
        If t3 > 0 Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 12
            For j = 22 To 23 'V:W sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                    sut = sut + 1
                End If
            Next j
        End If
        
    Next i
              
End Sub
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Ömer Bey; teşekkür ederim. çalışıyor. İyi ki varsınız.
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Ömer bey bugün dikkatimi çekti. aktarım yaparken dolu hücreleri sola yaslayarak aktarım yapıyor. bu da haftanın günlerine yanlış aktarım yapılmasına sebep oluyor.
Örneğin
5-0-0-5-0 olan bir hücre satırı ( Pazartesi- perşembe olması gerekirken)
5-5-0-0-0 şeklinde geliyor. (Pazartesi-Salı görünüyor)
Hücrelerin değerlerini (Eğer toplamı sıfırdan büyükse) doluluk durumuna göre aktarmamız mümkü mü?
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Bu şekilde deneyin.

Kod: 
Private Sub CommandButton1_Click()

    Dim S1 As Worksheet, i As Byte, t1, t2, t3, s As Integer, j As Byte, sut As Byte
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    
    Range("B6:M" & Rows.Count).ClearContents

    For i = 6 To 30
    
        t1 = Application.Sum(S1.Range(S1.Cells(i, "J"), S1.Cells(i, "N")))
        t2 = Application.Sum(S1.Range(S1.Cells(i, "P"), S1.Cells(i, "T")))
        t3 = Application.Sum(S1.Range(S1.Cells(i, "V"), S1.Cells(i, "W")))
        
        If t1 > 0 Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 10 To 14 'J:N sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
        
        If t2 > 0 Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 16 To 20 'P:T sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
        
        If t3 > 0 Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 12
            For j = 22 To 23 'V:W sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
        
    Next i
              
End Sub
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Teşekkür ederim Ömer Bey.
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Ömer Bey;

t1 = Application.Sum(S1.Range(S1.Cells(i, "J"), S1.Cells(i, "N"))) ----> Arası
If t1 > 0 Then ----------------------------------------------------------> 0 dan büyükse
((( J-N arası 0'dan büyükse... ))) ifadesi harika işimi görüyor.

Bunun yanında yukarıdaki denkeleme
((( E sütununda "Şef" yazıyorsa... ))) yorumunu nasıl eklemeliyim.
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Sonuç olarak:
((( J-N arası doluysa ))) ve ((( E sütununda Şef ayzıyorsa))) koşullarının ikisini birden sağlaması halinde
(((For j = 10 To 14 ))) arasını kopyala
demesi gerekiyor.
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
If t1 > 0 Then

yerine aşağıdaki gibi kullanın. And S1.Cells(i, "E") = "Şef" ilavesinin t2 ve t3 satırlarınada uygulayın.

If t1 > 0 And S1.Cells(i, "E") = "Şef" Then
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Teşekkür ederim Ömer Bey; Harika bilgiler için.
Üç buton koydum birinci buton ilk kodlarınızla çalışıyor.
ikinci buton da sonradan eklediğinizle çalışıyor. Bu ikisi için minnetarım.

üçüncü butonda şöyle bir önerme getirebilir miyiz?
((( J-N arası doluysa ))) ve ((( E sütununda Şef ve Müdür YAZMIYORSA))) koşullarını sağlaması halinde...
işleme son noktasını koyacağız inşallah.
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
If t1 > 0 And S1.Cells(i, "E") <> "Şef" And S1.Cells(i, "E") <> "Müdür" Then

Gibi ilave yapabilirsiniz.

Yalnız şef, müdür yada başka bir şart için büyük küçük harf duyarlılığı vardır. Bunun önüne geçmek için aşağıdaki gibi yazılması gerekir.
Kod: 
Private Sub CommandButton1_Click()

    Dim S1 As Worksheet, i As Byte, t1, t2, t3, s As Integer, j As Byte, sut As Byte, deg As String
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    
    Range("B6:M" & Rows.Count).ClearContents

    For i = 6 To 30
    
        t1 = Application.Sum(S1.Range(S1.Cells(i, "J"), S1.Cells(i, "N")))
        t2 = Application.Sum(S1.Range(S1.Cells(i, "P"), S1.Cells(i, "T")))
        t3 = Application.Sum(S1.Range(S1.Cells(i, "V"), S1.Cells(i, "W")))
        
        deg = UCase(Replace(Replace(S1.Cells(i, "E"), "ı", "I"), "i", "İ"))

        If t1 > 0 And deg <> "ŞEF" And deg <> "MÜDÜR" Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 10 To 14 'J:N sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
        
        If t2 > 0 And deg <> "ŞEF" And deg <> "MÜDÜR" Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 16 To 20 'P:T sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
        
        If t3 > 0 And deg <> "ŞEF" And deg <> "MÜDÜR" Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 12
            For j = 22 To 23 'V:W sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
        
    Next i
              
End Sub
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Şef ve Müdürü "E" sütununda sorgulamıyor. Muhtemelen ((( J-N arasında sorguluyor ))) Sanırım bu yüzden doğru sonuç vermiyor.
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Pardon hocam, ben yanlış girmişim. Doğru sonuç veriyor. Teşekkürler
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Ömer Bey, Ben sayfa içeriklerini (.xls) uzantılı dosyadan (.xlsm) uzantılı dosyaya aldım.

.xls'nin sınırı olan IV256'dan daha ileri hücreleri aktarmıyor. Nerede yanlış yapıyorum acaba?
 
G

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Ömer' Alıntı:
If t1 > 0 And S1.Cells(i, "E") <> "Şef" And S1.Cells(i, "E") <> "Müdür" Then

Gibi ilave yapabilirsiniz.

Yalnız şef, müdür yada başka bir şart için büyük küçük harf duyarlılığı vardır. Bunun önüne geçmek için aşağıdaki gibi yazılması gerekir.
Kod: 
Private Sub CommandButton1_Click()

    Dim S1 As Worksheet, i As Byte, t1, t2, t3, s As Integer, j As Byte, sut As Byte, deg As String
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Sayfa1")
   
    Range("B6:M" & Rows.Count).ClearContents

    For i = 6 To 30
   
        t1 = Application.Sum(S1.Range(S1.Cells(i, "J"), S1.Cells(i, "N")))
        t2 = Application.Sum(S1.Range(S1.Cells(i, "P"), S1.Cells(i, "T")))
        t3 = Application.Sum(S1.Range(S1.Cells(i, "V"), S1.Cells(i, "W")))
       
        deg = UCase(Replace(Replace(S1.Cells(i, "E"), "ı", "I"), "i", "İ"))

        If t1 > 0 And deg <> "ŞEF" And deg <> "MÜDÜR" Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 10 To 14 'J:N sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
       
        If t2 > 0 And deg <> "ŞEF" And deg <> "MÜDÜR" Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 7
            For j = 16 To 20 'P:T sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
       
        If t3 > 0 And deg <> "ŞEF" And deg <> "MÜDÜR" Then
            s = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(s, "C") = S1.Cells(i, "B")
            Cells(s, "D") = S1.Cells(i, "C")
            Cells(s, "E") = S1.Cells(i, "E")
            sut = 12
            For j = 22 To 23 'V:W sütunları
                If S1.Cells(i, j) > 0 Then
                    Cells(s, sut) = S1.Cells(i, j)
                End If
                sut = sut + 1
            Next j
        End If
       
    Next i
             
End Sub
Genişletmek için tıkla ...

Ömer Bey, Bu kodu çok sık kullanıyorum.
"If t1 > 0" şeklinde neredeyse "If t100" e kadar geldim. Ve nihayet Kod uzun hatası almaya başladım. Kodları iki farklı modüle bölsem işime yaramıyor. Bütünlük bozuluyor. Tek modülde "kod uzun" hatası almadan veya bütünlüğü bozmadan nasıl bu kodları devam ettirebilirim acaba.
 
Ömer

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
100 adet yada daha fazla alan mı oluşturdunuz, aran aralıkları bir düzende ilerliyorsa döngü kurulabilir. Sorunuzu destekleyen bir dosya ekleyerek yapmak istediğinizi yeniden açıklar mısınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst