DOSYA BOYUTUNU KÜÇÜLTME DONMAYI AZALTMA

[selejdonk61]

Merhabalar..Ekteki dosyada ilk sayfada firmadan çalışan personel listesi var(Örnek 3 kişi). Diğer sayfalar ise görüldüğü üzere aylar. Fİrmada çalışan personel rapor aldığı zaman gerekli bilgileri ilgili aya giriyoruz.Personelin kaç rapor aldığı ise ilk sekmede personel listesinde ismin karşısında yazıyor. Şöyle bir sorunum var, Çalışma sayfası çok ağır ve sürekli donuyor.(Deneme amaçlı 3 kişi yazıldı ancak bu sayı her ay için en az 150) Ya dosya boyutunu küçültmeliyim, ya da formüllerde bir değişiklik yapmalıyım..Yardımcı olursanız sevinirim.

 

[selejdonk61]

Dosya yükleyemiyorum. Boyut çok büyük, yardımcı olursanız sevinirim.

 

[S.Yiğit]

Dosya yükleyemiyorum. Boyut çok büyük, yardımcı olursanız sevinirim.

Merhaba,

Boş satır ve sütunların tamamını silin.. Bende bir çok kere işe yaradı.. İşe yaramazsa dosya.tc gibi sitelerden yükleyip link atarsanız inceleyebiliriz..

 

[selejdonk61]

Merhaba,

Boş satır ve sütunların tamamını silin.. Bende bir çok kere işe yaradı.. İşe yaramazsa dosya.tc gibi sitelerden yükleyip link atarsanız inceleyebiliriz..

https://www.dosya.tc/server20/jt451e/RAPOR_ONAY_VE_TAKIP_DEVAM_EDILEN_.xlsx.html

 

[selejdonk61]

Yardım edebilecek biri var mı?

 

[PriveT]

Merhaba,
Kontrol ediniz dosyada bir kayıp var mı?

http://s4.dosya.tc/server6/3nv35o/RAPOR_ONAY_VE_TAKIP_DEVAM_EDILEN_.xlsx.html

 

[selejdonk61]

Merhaba,
Kontrol ediniz dosyada bir kayıp var mı?

http://s4.dosya.tc/server6/3nv35o/RAPOR_ONAY_VE_TAKIP_DEVAM_EDILEN_.xlsx.html

Merhabalar.Araya haftasonu girdiğinden bakamamıştım.Görünürde dosya boyutu küçülmüş bunun için teşekkür ederim, fakat dosya içeriğinde yine donmalar meydana geliyor.Buna bir çözüm bulabilir miyiz?Öğrenmek için soruyorum..Dosyanın boyutunu bu denli nasıl küçültebildiniz?

 

[PriveT]

Merhaba,
Dosyanızda donmalar meydana gelmesinin sebebi formülle bütün sayfaları aratıp bu sayfalardan veri çekmeniz olsa gerek.
Bunu önlemek için MAKROLU çözüm bulmanızı tavsiye ederim.

Dosyanın boyutunu küçültme kısmına gelince; burada veya yabancı bir forumda bulduğum, aşağıda paylaştığım makro kodunu dosyaya uyguluyorsunuz.

Option Explicit
 
Sub ExcelDiet()
    
    Dim j               As Long
    Dim k               As Long
    Dim LastRow         As Long
    Dim LastCol         As Long
    Dim ColFormula      As Range
    Dim RowFormula      As Range
    Dim ColValue        As Range
    Dim RowValue        As Range
    Dim Shp             As Shape
    Dim ws              As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error Resume Next
    
    For Each ws In Worksheets
        With ws
             'Find the last used cell with a formula and value
             'Search by Columns and Rows
            On Error Resume Next
            Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            On Error GoTo 0
            
             'Determine the last column
            If ColFormula Is Nothing Then
                LastCol = 0
            Else
                LastCol = ColFormula.Column
            End If
            If Not ColValue Is Nothing Then
                LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
            End If
            
             'Determine the last row
            If RowFormula Is Nothing Then
                LastRow = 0
            Else
                LastRow = RowFormula.Row
            End If
            If Not RowValue Is Nothing Then
                LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
            End If
            
             'Determine if any shapes are beyond the last row and last column
            For Each Shp In .Shapes
                j = 0
                k = 0
                On Error Resume Next
                j = Shp.TopLeftCell.Row
                k = Shp.TopLeftCell.Column
                On Error GoTo 0
                If j > 0 And k > 0 Then
                    Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
                        j = j + 1
                    Loop
                    If j > LastRow Then
                        LastRow = j
                    End If
                    Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
                        k = k + 1
                    Loop
                    If k > LastCol Then
                        LastCol = k
                    End If
                End If
            Next
            
            .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
            .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Kodu herhangibir çalışma sayfasına modül olarak ekleyip çalıştırın.

İyi günler.

 

[selejdonk61]

Yardım ve nezaketiniz için teşekkür ederim.İyi günler diliyorum.

 

[PriveT]

Yardım ve nezaketiniz için teşekkür ederim.İyi günler diliyorum.

Rica ederim, aynı şekilde ben de size teşekkür ederim. İyi günler.