• DİKKAT

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

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

G

Gold_Savt

Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
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

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
 
Ömer Bey; teşekkür ederim. çalışıyor. İyi ki varsınız.
 
Ö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ü?
 
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
 
Ö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.
 
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.
 
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
 
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.
 
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
 
Ş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.
 
Pardon hocam, ben yanlış girmişim. Doğru sonuç veriyor. Teşekkürler
 
Ö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?
 
Ö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.
 
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.
Geri
Üst