Sayfalardan (-) Eksi Değerleri Çekme

[o2l3m]

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.

 

[YUSUF44]

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:

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

 

[askm]

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

 

[muygun]

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

 

[o2l3m]

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.

 

[muygun]

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.

 

[o2l3m]

Kodları çalışma sayfama aktardım. Fakat yine bir sorun var. 3. vardiya hesaplamasında. :-(

 

[muygun]

Merhaba;
6 nolu mesaj ekini indirip deneyin.
Burda sorun varsa onu çözelim. (Hatalı dosyayı göremiyoruz.)
İyi çalışmalar.

 

[o2l3m]

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.

 

[YUSUF44]

Benim ve Sayın askm'nin kodlarını denediniz mi?

 

[o2l3m]

Ş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,

 

[YUSUF44]

Verdiğim kodda bir küçük hata yapmışım Aşağıdaki gibi deneyin:

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.

 

[muygun]

Merhaba;
Dosyanızı;
http://www.dosya.tc/
Sitesine yükleyerek link adresini burada paylaşın.
İyi çalışmalar.