Tablo içeriğini makro ile saymak

mersilen · 5 Ocak 2018

Merhabalar
Makro ile;
aşagıdaki tablodaki isimleri benzersiz W sütununa altalta yazdırılacak
Sütunlardaki sayılarınıda karşılığına yazdırılacak.
İlgilenenlere teşekkür ederim.

askm · 5 Ocak 2018

Kod:

Sub askm()
Dim son As Long
son = Range("A" & Rows.Count).End(xlUp).Row
a = 1
For satir = 2 To son
    For sutun = 2 To 21
        say = WorksheetFunction.CountIf(Range("W2:W" & a), Cells(satir, sutun))
        If Cells(satir, sutun) <> "" And say = 0 Then
            a = a + 1
            Cells(a, "W") = Cells(satir, sutun)
        End If
    Next sutun
Next satir
MsgBox "İşlem tamam...", vbInformation, "ASKM"

End Sub

mersilen · 5 Ocak 2018

Teşekkürler
Yalnız X ve AH sütunları arasını yapmıyor ( çeteleme ?).

askm · 5 Ocak 2018

Kod:

Sub askm()
Dim son As Long
Range("W1:W65000").ClearContents
son = Range("A" & Rows.Count).End(xlUp).Row
a = 1
For satir = 2 To son
    For sutun = 2 To 21
        say = WorksheetFunction.CountIf(Range("W2:W" & a), Cells(satir, sutun))
        If Cells(satir, sutun) <> "" And say = 0 Then
            a = a + 1
            Cells(a, "W") = Cells(satir, sutun)
        End If
    Next sutun
Next satir

For satir = 2 To son
    For sutun = 24 To 34
        say = WorksheetFunction.CountIf(Range("W2:W" & a), Cells(satir, sutun))
        If Cells(satir, sutun) <> "" And say = 0 Then
            a = a + 1
            Cells(a, "W") = Cells(satir, sutun)
        End If
    Next sutun
Next satir

MsgBox "İşlem tamam...", vbInformation, "ASKM"

End Sub

muygun · 5 Ocak 2018

Merhaba;
Alternatif:
Eki deneyin.
İyi çalışmalar.

mersilen · 5 Ocak 2018

Selam
Sayın askım
Kod çalışmıyor

mersilen · 5 Ocak 2018

Sayın uygun sizin makro çalışıyor
yalnız tö.yrg yi yanlış yapıyordu
Cells(i, "ad") = WorksheetFunction.CountIf(Range("o2:F32"), Cells(i, "w")) 'tö yrg sayımı
toplamda 22 iş günü var sütun sonunda 154 çıkıyor

("o2: o32") olarak düzelttim
Düzgün çalışıyor.
Herkese teşekkür ederim

muygun · 5 Ocak 2018

Merhaba;
Bende sonradan farkettim ve düzeltilmiş farklı bir uygulama yaptım.
İnceleyin.
İyi çalışmalar.

mersilen · 5 Ocak 2018

SAyın Muygun ilginize teşekkür ediyorum.

Makro gayet güzel çalışıyor.
Sayfa2 deki gün dağılımınıda yapmamız mümkün mü?
2. bir düğmede olabilir.

Ziynettin · 6 Ocak 2018

Merhaba,

Sayın Muygun çevrim dışı, farklı çalışma deneyiniz.

Kod:

Sub ifade_say()
son = Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
a = Range("B1:U" & son).Value
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
For i = 2 To UBound(a)
    For j = 1 To UBound(a, 2)
        If Not IsEmpty(a(i, j)) Then
            d1(a(i, j)) = ""
            deg = a(i, j) & a(1, j)
            d(deg) = d(deg) + 1
        End If
    Next j
Next i

ReDim b(1 To d1.Count, 1 To 1)
For Each v In d1.keys
    s = s + 1
    b(s, 1) = v
Next v

[W2].Resize(s) = b
On Error Resume Next
sut = Rows(1).Find("*", , , , xlByColumns, xlPrevious).Column
c = [W1].Resize(s + 1, sut).Value
ReDim b(1 To d1.Count, 1 To UBound(c, 2))
For i = 2 To UBound(c)
    For j = 2 To UBound(c, 2)
        deg = c(i, 1) & c(1, j)
        b(i - 1, j - 1) = d(deg)
    Next j
Next i

[X2].Resize(s, UBound(c, 2)) = b
MsgBox "işlem tamam.", vbInformation
End Sub

mersilen · 6 Ocak 2018

Ziynettin bey ilginize teşekkürler.

Kodlar çalışıyor,
yalnız gün dağılımını yapmadı. (AT ve BF sütunları arasını)

Ziynettin · 6 Ocak 2018

AT ve BF sütunları arasını sonradan fark ettim.

AT1 hücresindeki "SMU1+smu2+ADÖLESAN" küçük harfleri büyük harf olarak düzeltip bu şekilde deneyin.

Kod:

Sub ifade_say()
son = Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
a = Range("A1:U" & son).Value
veri_at1 = Split([AT1], "+")
veri_au1 = Split([AU1], "+")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")

For i = 2 To UBound(a)
    For j = 2 To UBound(a, 2)
        If Not IsEmpty(a(i, j)) Then
            d1([COLOR="Red"]Trim([/COLOR]a(i, j))[COLOR="red"])[/COLOR] = ""
            deg = [COLOR="red"]Trim([/COLOR]a(i, j)[COLOR="red"])[/COLOR] & a(1, j)
            d2(deg) = d2(deg) + 1

            '******************************************
            For x = 0 To UBound(veri_at1)
                If Split(a(1, j), "-")(1) = veri_at1(x) Then
                    deg = a(i, j) & Format(a(i, 1), "dddd")
                    d3(deg) = d3(deg) + 1
                End If
            Next x

'            '*******************************************
            For x = 0 To UBound(veri_au1)
                If Split(a(1, j), "-")(1) = veri_au1(x) Then
                    deg = a(i, j) & Format(a(i, 1), "dddd")
                    d4(deg) = d4(deg) + 1
                End If
            Next x
'            '********************************************
        End If
    Next j
Next i


ReDim b(1 To d1.Count, 1 To 1)
For Each v In d1.keys
    s = s + 1
    b(s, 1) = v
Next v


[W2].Resize(s) = b
tbl = Array(b)
c = [X1:AQ1]
ReDim b(1 To s, 1 To UBound(c, 2))
For x = 1 To s
    For y = 1 To UBound(c, 2)
        b(x, y) = d2(tbl(0)(x, 1) & c(1, y))
    Next y
Next x
[X2].Resize(s, UBound(c, 2)) = b


c1 = [AZ1:BF1]
ReDim b(1 To s, 1 To UBound(c1, 2))
ReDim b1(1 To s, 1 To UBound(c1, 2))
ReDim b2(1 To s, 1 To 2)
ReDim b3(1 To s, 1 To 1)
For i = 1 To s
    For y = 1 To UBound(c1, 2)
        b(i, y) = d3(tbl(0)(i, 1) & c1(1, y))
        b1(i, y) = d4(tbl(0)(i, 1) & c1(1, y))
        b2(i, 1) = b2(i, 1) + b(i, y)
        b2(i, 2) = b2(i, 2) + b1(i, y)
        b3(i, 1) = b3(i, 1) + b(i, y)
    Next y
Next i
[AZ2].Resize(s, UBound(c1, 2)) = b
[AT2].Resize(s, 2) = b2
[BH2].Resize(s) = b3

MsgBox "işlem tamam.", vbInformation
End Sub

mersilen · 6 Ocak 2018

Zynettin bey
tabloyu bu sefer hatalı dolduruyor.

Ziynettin · 6 Ocak 2018

Tablonuzdaki verilrin başında ya da sonunda boşluk olmasından olabilir. Kod satırında kırmızı yerleri düzeltip deneyin.

mersilen · 6 Ocak 2018

Gün dağılımında cumartesi ve pazarı yapmıyor, bazı günleri yanlış yapmış.
a12 de
salı 2
cuma 2
cumartesi 1 olması lazım

muygun · 6 Ocak 2018

Merhaba;
Veri doğruluğunu kontrol etmedim ama eki deneyin.
İyi çalışmalar.

Ziynettin · 6 Ocak 2018

Gün dağılımı tablosundaki soucu elle yazıp dosyanızı ekleyebilir misiniz.

mersilen · 6 Ocak 2018

Zynettin bey kusura bakmayın
ben tam olarak tarif edememişim.

08-smu nöbet ve 18-tö nöbet sütunlarını gün gün tabloya birleştirerek dağıtacak

Ziynettin · 6 Ocak 2018

...

Kod:

Sub deneme()
son = Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
a = Range("A1:U" & son).Value
veri_at1 = Split([AT1], "+")
veri_au1 = Split([AU1], "+")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")

For i = 2 To UBound(a)
    For j = 2 To UBound(a, 2)
        If Not IsEmpty(a(i, j)) Then
            d1(Trim(a(i, j))) = ""
            deg = Trim(a(i, j)) & a(1, j)
            d2(deg) = d2(deg) + 1

            '******************************************
            If a(1, j) = "08-SMU NÖBET" Or a(1, j) = "18-TÖ NÖBET" Then
                deg = a(i, j) & Format(a(i, 1), "dddd")
                d3(deg) = d3(deg) + 1
            End If

'            '*******************************************
            For x = 0 To UBound(veri_au1)
                If Split(a(1, j), "-")(1) = veri_au1(x) Then
                    deg = a(i, j) & Format(a(i, 1), "dddd")
                    d4(deg) = d4(deg) + 1
                End If
            Next x
'            '********************************************
        End If
    Next j
Next i


ReDim b(1 To d1.Count, 1 To 1)
For Each v In d1.keys
    s = s + 1
    b(s, 1) = v
Next v


[W2].Resize(s) = b
tbl = Array(b)
c = [X1:AQ1]
ReDim b(1 To s, 1 To UBound(c, 2))
For x = 1 To s
    For y = 1 To UBound(c, 2)
        b(x, y) = d2(tbl(0)(x, 1) & c(1, y))
    Next y
Next x
[X2].Resize(s, UBound(c, 2)) = b


c1 = [AZ1:BF1]
ReDim b(1 To s, 1 To UBound(c1, 2))
ReDim b1(1 To s, 1 To UBound(c1, 2))
ReDim b2(1 To s, 1 To 2)
ReDim b3(1 To s, 1 To 1)
For i = 1 To s
    For y = 1 To UBound(c1, 2)
        b(i, y) = d3(tbl(0)(i, 1) & c1(1, y))
        b1(i, y) = d4(tbl(0)(i, 1) & c1(1, y))
        b2(i, 1) = b2(i, 1) + b(i, y)
        b2(i, 2) = b2(i, 2) + b1(i, y)
        b3(i, 1) = b3(i, 1) + b(i, y)
    Next y
Next i
[AZ2].Resize(s, UBound(c1, 2)) = b
[AT2].Resize(s, 2) = b2
[BH2].Resize(s) = b3

MsgBox "işlem tamam.", vbInformation
End Sub

mersilen · 7 Ocak 2018

Teşekkür ederim

Tablo içeriğini makro ile saymak

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Özel Üye

Destek Ekibi

Destek Ekibi

Özel Üye

Ekli dosyalar

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Özel Üye

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Destek Ekibi