• DİKKAT

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

Sayfalardan (-) Eksi Değerleri Çekme

  • Konbuyu başlatan Konbuyu başlatan o2l3m
  • Başlangıç tarihi Başlangıç tarihi

o2l3m

Altın Üye
Katılım
2 Mart 2005
Mesajlar
156
Excel Vers. ve Dili
Microsoft® Excel ® 2016 (16.0.5413.1000) MSO (16.0.5413.1000) 32 bit
Vardiya Iskarta isimli bir veri dosyam var. İstedğimi 1-31 arasındaki numaralı sayfalardan y,ax,bw sütunlarından (-) değerleri çekerek alt alta listelemek. Çoketopla ile dosya çok kastığı veri aralığı çok uzun olduğu için makro konusunda yardımcı olursanız çok sevinirim.

Ekteki dosya üzerinde de detaylı olarak anlatmaya çalıştım.
 

Ekli dosyalar

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Makro örnek dosyanızdaki gibi aynı dosya içinde yer alan ve adı Toplam olmayan sayfalardaki verileri Toplam sayfasına getirir:

Kod:
Sub topla()
Application.ScreenUpdating = False
Set s1 = Sheets("Toplam")
For sayfa = 1 To Sheets.Count
    If Sheets(sayfa).Name <> s1.Name Then
        son = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row
        For malzeme = 2 To son
            If Sheets(sayfa).Cells(malzeme, "Y") < 0 Or Sheets(sayfa).Cells(malzeme, "AX") < 0 Or _
                Sheets(sayfa).Cells(malzeme, "BW") Then
                yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
                s1.Cells(yeni, "B") = Sheets(sayfa).Name
                s1.Cells(yeni, "C") = Sheets(sayfa).Cells(malzeme, "A")
                If Sheets(sayfa).Cells(malzeme, "Y") < 0 Then s1.Cells(yeni, "D") = Sheets(sayfa).Cells(malzeme, "Y")
                If Sheets(sayfa).Cells(malzeme, "AX") < 0 Then s1.Cells(yeni, "E") = Sheets(sayfa).Cells(malzeme, "AX")
                If Sheets(sayfa).Cells(malzeme, "BW") < 0 Then s1.Cells(yeni, "F") = Sheets(sayfa).Cells(malzeme, "BW")
            End If
        Next
    End If
Next

veri = s1.Cells(Rows.Count, "B").End(3).Row
For i = 4 To veri
    s1.Cells(i, "D") = WorksheetFunction.SumIfs(s1.Range("D4:D" & veri), s1.Range("B4:B" & veri), s1.Cells(i, "B"), s1.Range("C4:C" & veri), s1.Cells(i, "C"))
    s1.Cells(i, "E") = WorksheetFunction.SumIfs(s1.Range("E4:E" & veri), s1.Range("B4:B" & veri), s1.Cells(i, "B"), s1.Range("C4:C" & veri), s1.Cells(i, "C"))
    s1.Cells(i, "F") = WorksheetFunction.SumIfs(s1.Range("F4:F" & veri), s1.Range("B4:B" & veri), s1.Cells(i, "B"), s1.Range("C4:C" & veri), s1.Cells(i, "C"))
    s1.Cells(i, "G") = s1.Cells(i, "D") + s1.Cells(i, "E") + s1.Cells(i, "F")
Next

s1.Range("$B$3:$G$" & veri).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI"

End Sub
 
Kod:
Sub ASKM_SAYFALARDAN_AL()
Dim Son As Long
Sheets("Toplam").Range("B4:G65000").ClearContents
a = 4
For Syf = 1 To Sheets.Count
    If Sheets(Syf).Name <> "Toplam" Then
        Son = Sheets(Syf).Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To Son
            If Sheets(Syf).Cells(i, 25) < 0 Then
                Sheets("Toplam").Cells(a, 2) = Sheets(Syf).Name
                Sheets("Toplam").Cells(a, 3) = Sheets(Syf).Cells(i, 1)
                Sheets("Toplam").Cells(a, 4) = Sheets(Syf).Cells(i, 25)
            End If
            If Sheets(Syf).Cells(i, 50) < 0 Then
                Sheets("Toplam").Cells(a, 2) = Sheets(Syf).Name
                Sheets("Toplam").Cells(a, 3) = Sheets(Syf).Cells(i, 1)
                Sheets("Toplam").Cells(a, 5) = Sheets(Syf).Cells(i, 50)
            End If
            If Sheets(Syf).Cells(i, 75) < 0 Then
                Sheets("Toplam").Cells(a, 2) = Sheets(Syf).Name
                Sheets("Toplam").Cells(a, 3) = Sheets(Syf).Cells(i, 1)
                Sheets("Toplam").Cells(a, 6) = Sheets(Syf).Cells(i, 75)
            End If
        Sheets("Toplam").Cells(a, 7) = Sheets("Toplam").Cells(a, 4) + Sheets("Toplam").Cells(a, 5) + Sheets("Toplam").Cells(a, 6)
        a = a + 1
        Next i
     End If
Next Syf
MsgBox "İşlem Tamam...", vbInformation, "ASKM"
End Sub
 
Son düzenleme:
Merhaba

Analiz tablosunda ve Rapor sayfasında bir hata var. - değerleri toplarken 3. Vardiya sütununa verileri doğru getirmediğini gördüm. İnceleyebilir misiniz?



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

Ekli dosyalar

  • 2018-01-25_092724.jpg
    2018-01-25_092724.jpg
    16.3 KB · Görüntüleme: 7
  • 2018-01-25_092756.jpg
    2018-01-25_092756.jpg
    20.3 KB · Görüntüleme: 4
Merhaba;
Haklısınız (Analiz işlemi butonunda tablo silme işlemi için ilgili sütunu eksik tanımladığım için bu sütunda önceki veriler kalıyordu. Düzelttim.)
Ayrıca 3-Rapor butonunun bağlı olduğu makroda da düzenleme yaptım.
Ayrıca Toplam ve Analiz sayfasında 1 satıra kontrol toplamları ekledim (gereksiz görürseniz formülleri silebilirsiniz. Tablonun işleyişinde fonksiyonel etkisi yok)

İyi çalışmalar.
 

Ekli dosyalar

Son düzenleme:
Kodları çalışma sayfama aktardım. Fakat yine bir sorun var. 3. vardiya hesaplamasında. :-(
 
Merhaba;
6 nolu mesaj ekini indirip deneyin.
Burda sorun varsa onu çözelim. (Hatalı dosyayı göremiyoruz.)
İyi çalışmalar.
 
Merhabalar;

Dosyayı zipledim. Mail adresi verebilirmisiniz? 3.vardiya hesaplamalarında Makro kararsız çalışıyor ve sorunu bulamadım :-(

Teşekkürler,


Merhaba;
6 nolu mesaj ekini indirip deneyin.
Burda sorun varsa onu çözelim. (Hatalı dosyayı göremiyoruz.)
İyi çalışmalar.
 
Benim ve Sayın askm'nin kodlarını denediniz mi?
 
Şu anda ay sonu olması sebebi ile 31 adet sayfa var.
Ve bu konu altındaki 3 kod da kararsız çalışıyor.

Kodları çalışma kitabına aldım. Dilerseniz dosyayı gönderebilirim. Fakat siteye upload edemiyorum,

Ay sonu olması sebebi ile yardım ederseniz çok memnun olurum,
 
Verdiğim kodda bir küçük hata yapmışım :( Aşağıdaki gibi deneyin:

Kod:
Sub topla()
Application.ScreenUpdating = False
Set s1 = Sheets("Toplam")
For sayfa = 1 To Sheets.Count
    If Sheets(sayfa).Name <> s1.Name Then
        son = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row
        For malzeme = 2 To son
            If Sheets(sayfa).Cells(malzeme, "Y") < 0 Or Sheets(sayfa).Cells(malzeme, "AX") < 0 Or _
                Sheets(sayfa).Cells(malzeme, "BW") [COLOR="Red"]< 0[/COLOR] Then
                yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
                s1.Cells(yeni, "B") = Sheets(sayfa).Name
                s1.Cells(yeni, "C") = Sheets(sayfa).Cells(malzeme, "A")
                If Sheets(sayfa).Cells(malzeme, "Y") < 0 Then s1.Cells(yeni, "D") = Sheets(sayfa).Cells(malzeme, "Y")
                If Sheets(sayfa).Cells(malzeme, "AX") < 0 Then s1.Cells(yeni, "E") = Sheets(sayfa).Cells(malzeme, "AX")
                If Sheets(sayfa).Cells(malzeme, "BW") < 0 Then s1.Cells(yeni, "F") = Sheets(sayfa).Cells(malzeme, "BW")
            End If
        Next
    End If
Next

veri = s1.Cells(Rows.Count, "B").End(3).Row
For i = 4 To veri
    s1.Cells(i, "D") = WorksheetFunction.SumIfs(s1.Range("D4:D" & veri), s1.Range("B4:B" & veri), s1.Cells(i, "B"), s1.Range("C4:C" & veri), s1.Cells(i, "C"))
    s1.Cells(i, "E") = WorksheetFunction.SumIfs(s1.Range("E4:E" & veri), s1.Range("B4:B" & veri), s1.Cells(i, "B"), s1.Range("C4:C" & veri), s1.Cells(i, "C"))
    s1.Cells(i, "F") = WorksheetFunction.SumIfs(s1.Range("F4:F" & veri), s1.Range("B4:B" & veri), s1.Cells(i, "B"), s1.Range("C4:C" & veri), s1.Cells(i, "C"))
    s1.Cells(i, "G") = s1.Cells(i, "D") + s1.Cells(i, "E") + s1.Cells(i, "F")
Next

s1.Range("$B$3:$G$" & veri).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI"

End Sub

Dosyayı siteye yükleyemiyorsanız paylaşım sitelerinden birine yükleyip burada linkini paylaşabilirsiniz.
 
Merhaba;
Dosyanızı;
http://www.dosya.tc/
Sitesine yükleyerek link adresini burada paylaşın.
İyi çalışmalar.
 
Geri
Üst