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

balanar

Altın Üye
Katılım
22 Şubat 2021
Mesajlar
347
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:

balanar

Altın Üye
Katılım
22 Şubat 2021
Mesajlar
347
Excel Vers. ve Dili
Excel 2007
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
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,615
Excel Vers. ve Dili
Microsoft 365 Tr-64
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
 

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,104
Excel Vers. ve Dili
office2010
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:

balanar

Altın Üye
Katılım
22 Şubat 2021
Mesajlar
347
Excel Vers. ve Dili
Excel 2007
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
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:

balanar

Altın Üye
Katılım
22 Şubat 2021
Mesajlar
347
Excel Vers. ve Dili
Excel 2007
Çok teşekkürler düzenledim hocam elinize sağlık toplam 1500 satırı ortalama 10snde yapıyor sizin kod ile
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
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
 

balanar

Altın Üye
Katılım
22 Şubat 2021
Mesajlar
347
Excel Vers. ve Dili
Excel 2007
Çok teşekkür ediyorum. Su bilgilerinizi açıkça kıskanıyorum keşke sizin kadar üstad olabilsek bizde..
 
Üst