• DİKKAT

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

Hücre birleştirme işlemi çok uzun sürüyor makro

B

balanar

Altın Üye
Katılım
22 Şubat 2021
Mesajlar
348
Excel Vers. ve Dili
Excel 2007
Yıllık izin dosyamız var başlangıç bitiş yerleri formüllerle ayarlandı. Makro ile hücre birleştirme yaptığımızda işlem çok uzun sürüyor bunu kısaltmak için ne yapabiliriz? Kullandığım makro kodu


Kod: 
Sub test()
    [I:I].Clear
    sSat = Cells(Rows.Count, 1).End(3).Row
    For i = sSat To 2 Step -1
        al1 = Cells(i, 1).Value & "|" & Cells(i, 2).Value
        son = 0
        toplam = Cells(i, 6).Value
        For ii = i - 1 To 1 Step -1
            al2 = Cells(ii, 1).Value & "|" & Cells(ii, 2).Value
            If al1 <> al2 Then
                i = ii + 1
                Cells(i, 9).Value = toplam
                Cells(i, 9).HorizontalAlignment = xlCenter
                If son <> 0 Then
                    With Range("I" & son & ":I" & i)
                        .MergeCells = True
                        .VerticalAlignment = xlCenter
                    End With
                End If
                Exit For
            Else
                If son = 0 Then son = i
                toplam = toplam + Cells(ii, 6).Value
            End If
        Next ii
    Next i
    Range("a2:I" & sSat).Borders.LineStyle = xlContinuous
End Sub
 
Son düzenleme:
A sutununda sicil numaraları var.. Aynı kişiye birkaç satır izin girilebiliyor..

yani atıyorum sicil numarası 200

200 3
200 5
200 7

sonra makroyu calıstırınca I sutununda bunların toplamını alıp hücre birleştiriyor 15 olarak yukardaki örnek için

Bunu başka bi excele alıp sadece sicil numarası ve izin günüyle yapınca oluyo fakat anadosyada başlangıç tarihli formüller var orada cok uzun sürüyor 30dk vs
 
Sizin de belirttiğinizi kodları yoracak her şey var dosyanızda.
Formüller, satır sayısı, hücre birleştirme, kenarlık düzenleme, hücre hizalama ....
Dosya formatınıza biraz kafa yormalısınız
 
Dizi ve set atama yöntemi çalışması.

Veri satır sayınızı göre ne kadar sürede işlem alınıyor.

Kod: 
Sub kod()
Set ds = CreateObject("scripting.dictionary")
Set dt = CreateObject("scripting.dictionary")
Set dz = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
son = Cells(Rows.Count, 1).End(xlUp).Row

If saon < 2 Then Exit Sub

Set alan = Range("A2:I" & son)
a = alan.Value
ReDim b(1 To UBound(a), 1 To 1)

For i = 1 To UBound(a)
    krt = a(i, 1) & "#" & a(i, 2)
    If Not ds.exists(krt) Then ds(krt) = i
    dz(krt) = dz(krt) + 1
    dt(krt) = dt(krt) + a(i, 6)
    b(ds(krt), 1) = dt(krt)
Next i

v1 = ds.items:    v2 = dz.items

[I2].Resize(UBound(a)) = b
[I2].Resize(UBound(a)).VerticalAlignment = xlCenter
[I2].Resize(UBound(a)).HorizontalAlignment = xlCenter
alan.Borders.LineStyle = xlContinuous

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

    For i = 0 To ds.Count - 1
        alan.Cells(v1(i), 9).Resize(v2(i)).Merge
    Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "İşlem bitti...." & vbLf & vbLf & _
        CDate(TimeValue(Now) - Z), vbInformation
End Sub
 
Son düzenleme:
Ziynettin' Alıntı:
Dizi ve set atama yöntemi çalışması.

Veri satır sayınızı göre ne kadar sürede işlem alınıyor.

Kod: 
Sub kod()
Set ds = CreateObject("scripting.dictionary")
Set dt = CreateObject("scripting.dictionary")
Set dz = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
Set alan = Range("A2:I" & 22)
a = alan.Value
ReDim b(1 To UBound(a), 1 To 1)

For i = 1 To UBound(a)
    krt = a(i, 1) & "#" & a(i, 2)
    If Not ds.exists(krt) Then ds(krt) = i
    dz(krt) = dz(krt) + 1
    dt(krt) = dt(krt) + a(i, 6)
    b(ds(krt), 1) = dt(krt)
Next i

v1 = ds.items:    v2 = dz.items

[I2].Resize(UBound(a)) = b
[I2].Resize(UBound(a)).VerticalAlignment = xlCenter
[I2].Resize(UBound(a)).HorizontalAlignment = xlCenter
alan.Borders.LineStyle = xlContinuous

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

    For i = 0 To ds.Count - 1
        alan.Cells(v1(i), 9).Resize(v2(i)).Merge
    Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "İşlem bitti...." & vbLf & vbLf & _
        CDate(TimeValue(Now) - Z), vbInformation
End Sub
Genişletmek için tıkla ...

hocam sizin verdiğiniz bu kodla 9 saniyede yaptı. Fakat 21. satırdan sonra işlem yapmıyor

onuda sanırım
Set alan = Range("A2:I" & 22)
şuradan değişiyoruz değil mi hocam?
 
Son düzenleme:
Çok teşekkürler düzenledim hocam elinize sağlık toplam 1500 satırı ortalama 10snde yapıyor sizin kod ile
 
Kod: 
Sub test()
    Dim i&, ii&, son&, lst, b, zaman
    zaman = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    [I:I].Clear

    son = Cells(Rows.Count, 1).End(3).Row
    lst = Range("A2:I" & son).Value
    ReDim b(1 To UBound(lst), 1 To 1)

    For i = UBound(lst) To 2 Step -1
        If b(i, 1) = Empty Then b(i, 1) = lst(i, 6)
        If lst(i, 1) & "|" & lst(i, 2) = _
           lst(i - 1, 1) & "|" & lst(i - 1, 2) Then
            b(i - 1, 1) = lst(i - 1, 6) + b(i, 1)
            b(i, 1) = Empty
        End If
    Next i

    With Range("I2:I" & son)
        .Value = b
        .Borders.LineStyle = xlContinuous
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        For Each b In .SpecialCells(xlBlanks).Areas
            Union(b, b.Offset(-1)).MergeCells = True
        Next
    End With

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = True

    MsgBox "Veri aktarimi tamamlanmistir." & Chr(10) & Chr(10) & _
           "Islem süresi ; " & Format(Timer - zaman, "0.00") & " Saniye", vbInformation

End Sub
 
Çok teşekkür ediyorum. Su bilgilerinizi açıkça kıskanıyorum keşke sizin kadar üstad olabilsek bizde..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst