• DİKKAT

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

Parantezi saymasın

  • Konbuyu başlatan Konbuyu başlatan serif11
  • Başlangıç tarihi Başlangıç tarihi
S

serif11

Banned
Katılım
2 Eylül 2006
Mesajlar
135
Excel Vers. ve Dili
Excel XP tr
Arkadaşlar selam.
Karışık bir sorum olacak.
Aylara ait sayfaların olduğu bir dosyam var. Her aya ait sayfaya manuel veri giriyorum. Bu sayfaların A sütununda bulunan hata nedenlerini "HATA NEDENLERİ" sayfasına süzerek aktarıyor ve bu hatanın toplam sayısını buluyorum.
Buraya kadar sorun yok.
Örnek :

Diyelim ki "ölçüsel hata" diye bir hata çeşidimiz var. Ocak ayında 3 kez, Şubat ayında 2 kez ve Mart ayında da 4 kez olmak üzere 9 kez bu hata kaydı yapılmış.
HATA NEDENLERİ sayfasının B sütununa Ölçüsel hata, C sütununa da 9 kez diye süzerek aktarıyorum.
Ancak kimi zaman bu hata nedeninin yanına mecburen parantez içinde (Adapazarı) diye yazmak zorundayım.
Örnek:
Ocak ayında 1 kez, Şubat ayında 2 kez ve Mart ayında da 3 kez olmak üzere toplam 6 kez Ölçüsel hata(Adapazarı) kaydı yapılmış.

Süzerken mecburen bunlar ayrı ayrı süzülüyor.
Yani "HATA NEDENLERİ" sayfasında Ölçüsel hata 9 kez ve Ölçüsel hata(Adapazarı) 6 kez şeklinde 2 değişik kayıt oluşuyor.

Sorum şu:
Bu parantezi görmeden aylar sayfalarındaki hata nedenlerindeki parantez içini görmeden tek bir şekilde süzsün.
Örneğimize dönersek:
HATA NEDENLERİ sayfasında;
"Ölçüsel Hata" - "15 kez" diye tek bir süzme gerçekleşsin istiyorum.

(Sanmıyorum ya) Umarım anlatabilmişimdir
Şunu baştan söyleyeyim, dosya ekleme olanağım yok.
Şimdiden teşekkürler...
 
serif1' Alıntı:
Şunu baştan söyleyeyim, dosya ekleme olanağım yok.
Genişletmek için tıkla ...

Dosya yapısını görmeden kod yada formul yazma boşa harcanacak zaman olur. Örnek dosyanızı yapısını bozmadan kopyasını oluşturup verileri sallayınız ve imza kısmını okuyup dosyanızı ekleyinki konunuz ilgi görsün. Karar sizin.
 
Altın üye olmayanlar buraya nasıl dosya yüklüyordu unuttum.. Link verebilir misiniz?
 
Son düzenleme:
Merhaba
"MRK Nedenleri" sayfasında bulunan "Commandbutton1" kodlarındaki iki siyah aralıkta aşağıdaki (mavi) değişikliği yaparakdeneyiniz.
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
    Range("A2:C" & Rows.Count).Clear
    Application.ScreenUpdating = False
[COLOR="Blue"]   sat = 2
For i = 1 To Worksheets.Count - 2
    son = Worksheets(i).Range("E5000").End(3).Row + 1
 For j = 2 To son
 If Sheets(i).Cells(j, "E") <> "" Then
 If UBound(Split(Sheets(i).Cells(j, "E"), "(")) > 0 Then
 ht = Split(Sheets(i).Cells(j, "E"), "(")(0)
 Else
 ht = Sheets(i).Cells(j, "E")
 End If
 If WorksheetFunction.CountIf(Range("B2:B" & sat), Trim(ht)) = 0 Then
 Cells(sat, "A") = sat - 1
Cells(sat, "B") = Trim(ht)
Cells(sat, "C") = Sheets(i).Cells(j, "G")
 sat = sat + 1
 Else
r = [B:B].Find(Trim(ht), , xlValues, xlWhole).Row
 Cells(r, "C") = Sheets(i).Cells(j, "G") + Cells(r, "C")
 End If: End If
Next j
    Next i

 son = Range("B5000").End(3).Row
    For i = 1 To Worksheets.Count - 2
        son = Worksheets(i).Range("E5000").End(3).Row
            For j = 2 To son
                For s = 2 To Range("B5000").End(3).Row
                    Cells(s, 1).HorizontalAlignment = xlCenter
                    Cells(s, 3).HorizontalAlignment = xlCenter
                    Cells(s, 2).HorizontalAlignment = xlLeft
                    Range("A2:C" & Range("c5000").End(3).Row).Borders.LineStyle = 1
                    Range("A2:C" & n + 1).Borders.Color = vbBlue
                    Range("A" & i & ":C" & i).Interior.ColorIndex = 36
                    Range("A" & i + 1 & ":C" & i + 1).Interior.ColorIndex = 34
                    Range("A" & n + 1 & ":C" & n + 1).Interior.ColorIndex = 45
                    
                Next s
                
            Next j
        Next i[/COLOR]
    Module2.sirala
 ActiveWindow.SmallScroll Down:=-18
'....
'....diğer kodlarınız
'...
End sub
 [/SIZE]
 
Plint arkadaşım.
Öncelikle ilgi ve emeğinize teşekkür ederim.
Hataları süzmüş ancak "MRK Nedenleri" sayfasının C sütununa, aylara ait sayfalardaki İADE MİKTARINI değil o hata çeşidinin toplam sayısını yazması lazım.
Bir de işlem çok uzuyor.
Döngü sanırım yanlış yerde konmuş.
 
serif1' Alıntı:
Plint arkadaşım.
Öncelikle ilgi ve emeğinize teşekkür ederim.
Hataları süzmüş ancak "MRK Nedenleri" sayfasının C sütununa, aylara ait sayfalardaki İADE MİKTARINI değil o hata çeşidinin toplam sayısını yazması lazım.
Bir de işlem çok uzuyor.
Döngü sanırım yanlış yerde konmuş.
Genişletmek için tıkla ...
Merhaba
Sn vardar07 cevap vermiş ama affına sığınarak alternatif olsun,
Ek dosyayı inceleyiniz
http://dosya.co/2t7ot9vqs7e7/MRK2.zip.html
Ağırlaşmanın sebebi sayfalardaki satırları döngü ile tekrar biçimlendirmesi gibi görünüyor.
Buton kodlarını komple değişerek deneyiniz.
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
    Range("A2:C" & Rows.Count).Clear
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   sat = 2
For i = 1 To Worksheets.Count - 2
    son = Worksheets(i).Range("E5000").End(3).Row + 1
 For j = 2 To son
 If Sheets(i).Cells(j, "E") <> "" Then
 If UBound(Split(Sheets(i).Cells(j, "E"), "(")) > 0 Then
 ht = Split(Sheets(i).Cells(j, "E"), "(")(0)
 Else
 ht = Sheets(i).Cells(j, "E")
 End If
 If WorksheetFunction.CountIf(Range("B2:B" & sat), Trim(ht)) = 0 Then
 Cells(sat, "A") = sat - 1
Cells(sat, "B") = Trim(ht)
Cells(sat, "C") = Cells(sat, "C") + 1
 sat = sat + 1
 Else
r = [B:B].Find(Trim(ht), , xlValues, xlWhole).Row
 Cells(r, "C") = Cells(r, "C") + 1
 End If: End If
Next j
    Next i
[COLOR="Red"]Call sirala[/COLOR]
 x = Cells(Rows.Count, 1).End(3).Row
Range("A2:A" & x).HorizontalAlignment = xlCenter
Range("C2:C" & x).HorizontalAlignment = xlCenter
Range("B2:B" & x).HorizontalAlignment = xlLeft
Range("A2:C" & x).Borders.LineStyle = 1
Range("A2:C1").Borders.Color = vbBlue
Range("A2:C1").Interior.ColorIndex = 45
Range("A2:C" & x).Interior.ColorIndex = 36
For c = 3 To x Step 2
    With Range("A" & c & ":C" & c).Interior
        .ColorIndex = 34
        .Pattern = xlSolid
    End With
    Next
  Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam", vbInformation, "Serif"
End Sub

 [/SIZE]
 
Son düzenleme:
Sayın vardar07 ve Plint.
Öncelikle İkinizin de ilgi ve emeğine teşekkür ederim.
Sayın vardar07.
Sayın plintin ilk yolladığı kodlardaki hata sizde de oluşmuş, yani, iade miktarı değil de hata sayısı toplamını yazması gerekiyordu.
Sayın Plint.
İstediğim sonuç buydu. Fakat ufak bir düzeltme rica edecektim.
MRK sayısı (yani C sütunu) en büyükten en küçüğe doğru sıralaması lazım.
Tekrar teşekkür ederim.
 
serif1' Alıntı:
İstediğim sonuç buydu. Fakat ufak bir düzeltme rica edecektim.
MRK sayısı (yani C sütunu) en büyükten en küçüğe doğru sıralaması lazım.
Tekrar teşekkür ederim.
Genişletmek için tıkla ...
Son mesajımdaki kodlara düzeltme ile eklemiştim (kırmızı bölüm),
sizde eklerseniz modülde bulunan kodlarınız sıralamayı yapacaktır.

Kod: 
'....
Next j
    Next i
[COLOR="Red"]Call sirala[/COLOR]
 x = Cells(Rows.Count, 1).End(3).Row
Range("A2:A" & x).HorizontalAlignment = xlCenter
'...
 
Plint arkadaşım..
İşlem tamam.
Her ikinize de çok çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst