• DİKKAT

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

Tablo içeriğini makro ile saymak

  • Konbuyu başlatan Konbuyu başlatan mersilen
  • Başlangıç tarihi Başlangıç tarihi
M

mersilen

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,105
Excel Vers. ve Dili
excel 2007 türkçe
Excel Vers. ve Dili Ofis 2003
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.
 
Son düzenleme:
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
 
Teşekkürler
Yalnız X ve AH sütunları arasını yapmıyor ( çeteleme ?).
 
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
 
Merhaba;
Alternatif:
Eki deneyin.
İyi çalışmalar.
 
Son düzenleme:
Selam
Sayın askım
Kod çalışmıyor
 
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
 
Merhaba;
Bende sonradan farkettim ve düzeltilmiş farklı bir uygulama yaptım.
İnceleyin.
İyi çalışmalar.
 

Ekli dosyalar

Son düzenleme:
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.
 

Ekli dosyalar

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
 
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ı)
 
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
 
Son düzenleme:
Zynettin bey
tabloyu bu sefer hatalı dolduruyor.
 

Ekli dosyalar

Tablonuzdaki verilrin başında ya da sonunda boşluk olmasından olabilir. Kod satırında kırmızı yerleri düzeltip deneyin.
 
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
 
Merhaba;
Veri doğruluğunu kontrol etmedim ama eki deneyin.
İyi çalışmalar.
 

Ekli dosyalar

Gün dağılımı tablosundaki soucu elle yazıp dosyanızı ekleyebilir misiniz.
 
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
 

Ekli dosyalar

...

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
 
Teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst