Mevcut makroyu hızlandırma

metin_0606 · 17 Ekim 2019

Makro Veri isimli sayfaya girdiğim verileri TC kimlik no ve çalışma durumu etkin olanları baz alarak süzüyor ve ANA SAYFA isimli sayfamda ilgili TC kimlik numarasının karşılığına bilgileri aktarıyor. Yalnız bunu veri sayısı çok olunca 3-4 dakikada yapıyor. Bu süreyi kısaltablirmiyiz acaba

kemalist · 18 Ekim 2019

Sub aktar_71()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için

Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Dim adr As String
Set sh = Sheets("ANA SAYFA")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
Set k = sh.Range("C2:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)
If Not k Is Nothing Then
adr = k.Address
Do
If sh.Cells(k.Row, "X").Value = "Etkin" Then
sh.Cells(k.Row, "B").Value = Range("B" & i).Value ' İLK SEÇENEK ANA SAYFA İKİNCİ SEÇENEK VERİ SAYFASI
sh.Cells(k.Row, "E").Value = Range("C" & i).Value
sh.Cells(k.Row, "I").Value = Range("D" & i).Value
sh.Cells(k.Row, "U").Value = Range("E" & i).Value
sh.Cells(k.Row, "Z").Value = Range("F" & i).Value
sh.Cells(k.Row, "M").Value = Range("G" & i).Value
sh.Cells(k.Row, "O").Value = Range("H" & i).Value
Exit Do
End If
Set k = sh.Range("C2:C" & Rows.Count).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Next
MsgBox "BITTI"

Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True

Yukarıdaki hodu kopyalayıp yapıştırın.
End Sub

kemalist · 18 Ekim 2019

MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Sanise", vbInformation

End Sub hemen önüne yukarıdaki kodu yapıştırırsanız zamanıda görürsünüz.

Korhan Ayhan · 18 Ekim 2019

Deneyiniz.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
    
    With S2
         Son = .Cells(.Rows.Count, 1).End(3).Row
        .Range("B2:B" & .Rows.Count).ClearContents
        .Range("B2:B" & Son).Formula = "=IFERROR(IF(INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))=0,""""," & _
                                       "INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))),0)"
        .Range("B2:B" & Son).Value = .Range("B2:B" & Son).Value
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

metin_0606 · 18 Ekim 2019

kemalist' Alıntı:
Sub aktar_71()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için

Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Dim adr As String
Set sh = Sheets("ANA SAYFA")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
Set k = sh.Range("C2:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)
If Not k Is Nothing Then
adr = k.Address
Do
If sh.Cells(k.Row, "X").Value = "Etkin" Then
sh.Cells(k.Row, "B").Value = Range("B" & i).Value ' İLK SEÇENEK ANA SAYFA İKİNCİ SEÇENEK VERİ SAYFASI
sh.Cells(k.Row, "E").Value = Range("C" & i).Value
sh.Cells(k.Row, "I").Value = Range("D" & i).Value
sh.Cells(k.Row, "U").Value = Range("E" & i).Value
sh.Cells(k.Row, "Z").Value = Range("F" & i).Value
sh.Cells(k.Row, "M").Value = Range("G" & i).Value
sh.Cells(k.Row, "O").Value = Range("H" & i).Value
Exit Do
End If
Set k = sh.Range("C2:C" & Rows.Count).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Next
MsgBox "BITTI"

Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True

Yukarıdaki hodu kopyalayıp yapıştırı

kemalist' Alıntı:
Sub aktar_71()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için

Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Dim adr As String
Set sh = Sheets("ANA SAYFA")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
Set k = sh.Range("C2:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)
If Not k Is Nothing Then
adr = k.Address
Do
If sh.Cells(k.Row, "X").Value = "Etkin" Then
sh.Cells(k.Row, "B").Value = Range("B" & i).Value ' İLK SEÇENEK ANA SAYFA İKİNCİ SEÇENEK VERİ SAYFASI
sh.Cells(k.Row, "E").Value = Range("C" & i).Value
sh.Cells(k.Row, "I").Value = Range("D" & i).Value
sh.Cells(k.Row, "U").Value = Range("E" & i).Value
sh.Cells(k.Row, "Z").Value = Range("F" & i).Value
sh.Cells(k.Row, "M").Value = Range("G" & i).Value
sh.Cells(k.Row, "O").Value = Range("H" & i).Value
Exit Do
End If
Set k = sh.Range("C2:C" & Rows.Count).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Next
MsgBox "BITTI"

Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True

Yukarıdaki hodu kopyalayıp yapıştırın.
End Sub

kemalist hocam kod gayet güzel çalıştı teşekkür ederim

metin_0606 · 18 Ekim 2019

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
   
    With S2
         Son = .Cells(.Rows.Count, 1).End(3).Row
        .Range("B2:B" & .Rows.Count).ClearContents
        .Range("B2:B" & Son).Formula = "=IFERROR(IF(INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))=0,""""," & _
                                       "INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))),0)"
        .Range("B2:B" & Son).Value = .Range("B2:B" & Son).Value
    End With
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

korhan hocam veri sayfasına yazdığım verileri aktar dediğimde veriyi taplodan siliyor ancak Ana sayfaya aktarmıyor

metin_0606 · 18 Ekim 2019

kemalist' Alıntı:
Sub aktar_71()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için

Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Dim adr As String
Set sh = Sheets("ANA SAYFA")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
Set k = sh.Range("C2:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)
If Not k Is Nothing Then
adr = k.Address
Do
If sh.Cells(k.Row, "X").Value = "Etkin" Then
sh.Cells(k.Row, "B").Value = Range("B" & i).Value ' İLK SEÇENEK ANA SAYFA İKİNCİ SEÇENEK VERİ SAYFASI
sh.Cells(k.Row, "E").Value = Range("C" & i).Value
sh.Cells(k.Row, "I").Value = Range("D" & i).Value
sh.Cells(k.Row, "U").Value = Range("E" & i).Value
sh.Cells(k.Row, "Z").Value = Range("F" & i).Value
sh.Cells(k.Row, "M").Value = Range("G" & i).Value
sh.Cells(k.Row, "O").Value = Range("H" & i).Value
Exit Do
End If
Set k = sh.Range("C2:C" & Rows.Count).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Next
MsgBox "BITTI"

Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True

Yukarıdaki hodu kopyalayıp yapıştırın.
End Sub

kemalist hocam 252nci satırdan sonra verileri başka hüçrelere aktarmış neden acaca

metin_0606 · 18 Ekim 2019

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
   
    With S2
         Son = .Cells(.Rows.Count, 1).End(3).Row
        .Range("B2:B" & .Rows.Count).ClearContents
        .Range("B2:B" & Son).Formula = "=IFERROR(IF(INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))=0,""""," & _
                                       "INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))),0)"
        .Range("B2:B" & Son).Value = .Range("B2:B" & Son).Value
    End With
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

[/QUO hocam hata benden kaynaklanmış kod gayet güzel çalışıyor tekrardan çok teşekkür ederim

kemalist · 18 Ekim 2019

metin_0606' Alıntı:
kemalist hocam 252nci satırdan sonra verileri başka hüçrelere aktarmış neden acaca

ben sizin kodunuzda değişiklik yapmadım.Sadece baş ve sona ilave ettim.

metin_0606 · 18 Ekim 2019

kemalist' Alıntı:
ben sizin kodunuzda değişiklik yapmadım.Sadece baş ve sona ilave ettim.

Hocam mevcut makrom sorunlu çalışıyor verileri aktardigimda Ana sayfamdaki verilerin bir kismi siliniyor bu kodu revize edemeyizmi

metin_0606 · 18 Ekim 2019

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
  
    With S2
         Son = .Cells(.Rows.Count, 1).End(3).Row
        .Range("B2:B" & .Rows.Count).ClearContents
        .Range("B2:B" & Son).Formula = "=IFERROR(IF(INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))=0,""""," & _
                                       "INDEX('" & S1.Name & "'!B:B,MATCH(A2,'" & S1.Name & "'!C:C,0))),0)"
        .Range("B2:B" & Son).Value = .Range("B2:B" & Son).Value
    End With
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan hocam çalışmamdaki Mevcut Makro ile örneğin Veri Sayfasına yazdığım sicilleri Ana Sayfaya aktardığımda Ana Sayfadaki E-I-L-M-O-U-Z sütunlarındaki mevcut bilgileri silerek aktarıyor. Aynı zamanda makro çok yavaş çalışıyor. Bu sorun neden olabilir acaba listemin son hali ektedir. Saygılarımla

Korhan Ayhan · 27 Ekim 2019

Sizin VERİ sayfanızda veri yok. Bu sebeple ANA SAYFA çalışma durumu "Etkin" olanların karşılığına boş veri geliyor. Aslında silme durumu yok. Sadece boş veri aktarımı var.

Ben en başta verdiğim kod ise ANA SAYFA isimli sayfadaki verileri VERİ isimli sayfaya aktarıyor. Ben sorunuzu yanlış anlamışım.

Ben sorunuzu şu şekilde anladım.

ANA SAYFA isimli sayfada "X" sütununda "Etkin" yazanları VERİ sayfasına aktarmak istiyorsunuz? Doğru mu anlamışım?

metin_0606 · 27 Ekim 2019

Korhan Ayhan' Alıntı:
Sizin VERİ sayfanızda veri yok. Bu sebeple ANA SAYFA çalışma durumu "Etkin" olanların karşılığına boş veri geliyor. Aslında silme durumu yok. Sadece boş veri aktarımı var.

Ben en başta verdiğim kod ise ANA SAYFA isimli sayfadaki verileri VERİ isimli sayfaya aktarıyor. Ben sorunuzu yanlış anlamışım.

Ben sorunuzu şu şekilde anladım.

ANA SAYFA isimli sayfada "X" sütununda "Etkin" yazanları VERİ sayfasına aktarmak istiyorsunuz? Doğru mu anlamışım?

Tam tersi korhan bey veri sayfasına yazdığım verileri Tc kimlik numarası ve çalışma durumu Etkin olanları baz alarak Ana sayfaya aktaracak. Çalışma Durumu Etkin olanları baz almasının nedeni Ana Sayfada aynı personelin birkaç kez işe giriş çıkışının olmasıdır. Yani mükerrer kayıtlarda İşten Ayrıldı kısmına değil çalışma durumu etkin olana verileri aktarmak istiyorum

metin_0606 · 27 Ekim 2019

Korhan Ayhan' Alıntı:
Sizin VERİ sayfanızda veri yok. Bu sebeple ANA SAYFA çalışma durumu "Etkin" olanların karşılığına boş veri geliyor. Aslında silme durumu yok. Sadece boş veri aktarımı var.

Ben en başta verdiğim kod ise ANA SAYFA isimli sayfadaki verileri VERİ isimli sayfaya aktarıyor. Ben sorunuzu yanlış anlamışım.

Ben sorunuzu şu şekilde anladım.

ANA SAYFA isimli sayfada "X" sütununda "Etkin" yazanları VERİ sayfasına aktarmak istiyorsunuz? Doğru mu anlamışım?

Bizim verileri çektiğimiz Ana data var ben yeri geldiğinde sicilleri yeri geldiğinde adres ve telefonları bu Ana Datadan toplu bir şekilde veri sayfasına ekleyip kendi Ana sayfama aktararak bilgileri güncel tutmak istiyorum

metin_0606 · 27 Ekim 2019

Korhan Ayhan' Alıntı:
Sizin VERİ sayfanızda veri yok. Bu sebeple ANA SAYFA çalışma durumu "Etkin" olanların karşılığına boş veri geliyor. Aslında silme durumu yok. Sadece boş veri aktarımı var.

Ben en başta verdiğim kod ise ANA SAYFA isimli sayfadaki verileri VERİ isimli sayfaya aktarıyor. Ben sorunuzu yanlış anlamışım.

Ben sorunuzu şu şekilde anladım.

ANA SAYFA isimli sayfada "X" sütununda "Etkin" yazanları VERİ sayfasına aktarmak istiyorsunuz? Doğru mu anlamışım?[/QUO

Dediğiniz gibi korhan hocam boş veri aktarımı var. Veri sayfasındaki bütün sütunların altının dolu olması gerekli. Peki veri sayfasında sadece dolu sütun hangisi ise o verileri aktar boş sütün varsa işlem yapma pas geç diyebilirmiyiz

Korhan Ayhan · 28 Ekim 2019

Aşağıdaki kod ile örnek dosyanızda ben yaklaşık 10 saniyede sonuç aldım.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Liste As Variant, X As Long, Zaman As Double
    Dim Tc_Bul As Range, Son As Long, Y As Byte, Baslik As Range
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
    
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Liste = S1.Range("B2:Z" & Son).Value
    
    For X = 1 To UBound(Liste)
        If Liste(X, 23) = "Etkin" Then
            Set Tc_Bul = S2.Range("A:A").Find(Liste(X, 2), , , xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 2 To S2.Cells(1, Columns.Count).End(1).Column
                    If WorksheetFunction.CountA(S2.Columns(Y)) - 1 > 0 Then
                        Set Baslik = S1.Rows(1).Find(S2.Cells(1, Y), , , xlWhole)
                        If Not Baslik Is Nothing Then
                            Liste(X, Baslik.Column - 1) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    S1.Range("B2:Z" & UBound(Liste) + 1) = Liste
    
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

metin_0606 · 28 Ekim 2019

Korhan Ayhan' Alıntı:

Aşağıdaki kod ile örnek dosyanızda ben yaklaşık 10 saniyede sonuç aldım.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Liste As Variant, X As Long, Zaman As Double
    Dim Tc_Bul As Range, Son As Long, Y As Byte, Baslik As Range
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
   
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Liste = S1.Range("B2:Z" & Son).Value
   
    For X = 1 To UBound(Liste)
        If Liste(X, 23) = "Etkin" Then
            Set Tc_Bul = S2.Range("A:A").Find(Liste(X, 2), , , xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 2 To S2.Cells(1, Columns.Count).End(1).Column
                    If WorksheetFunction.CountA(S2.Columns(Y)) - 1 > 0 Then
                        Set Baslik = S1.Rows(1).Find(S2.Cells(1, Y), , , xlWhole)
                        If Not Baslik Is Nothing Then
                            Liste(X, Baslik.Column - 1) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
   
    S1.Range("B2:Z" & UBound(Liste) + 1) = Liste
   
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan hocam kod çok güzel calisiyor yalnız Ana sayfa bende A2:Y aralığında Etkin'de W sütununda kodu bir türlü buna uyarlayamadim nereleri değiştirmem gerek acaba

metin_0606 · 28 Ekim 2019

Korhan Ayhan' Alıntı:

Aşağıdaki kod ile örnek dosyanızda ben yaklaşık 10 saniyede sonuç aldım.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Liste As Variant, X As Long, Zaman As Double
    Dim Tc_Bul As Range, Son As Long, Y As Byte, Baslik As Range
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
   
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Liste = S1.Range("B2:Z" & Son).Value
   
    For X = 1 To UBound(Liste)
        If Liste(X, 23) = "Etkin" Then
            Set Tc_Bul = S2.Range("A:A").Find(Liste(X, 2), , , xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 2 To S2.Cells(1, Columns.Count).End(1).Column
                    If WorksheetFunction.CountA(S2.Columns(Y)) - 1 > 0 Then
                        Set Baslik = S1.Rows(1).Find(S2.Cells(1, Y), , , xlWhole)
                        If Not Baslik Is Nothing Then
                            Liste(X, Baslik.Column - 1) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
   
    S1.Range("B2:Z" & UBound(Liste) + 1) = Liste
   
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

uyarladım korhan hocam çok teşekkür ederim çok hızlı bir makro zihninize sağlık

metin_0606 · 30 Ekim 2019

Korhan Ayhan' Alıntı:

Aşağıdaki kod ile örnek dosyanızda ben yaklaşık 10 saniyede sonuç aldım.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Liste As Variant, X As Long, Zaman As Double
    Dim Tc_Bul As Range, Son As Long, Y As Byte, Baslik As Range
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
   
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Liste = S1.Range("B2:Z" & Son).Value
   
    For X = 1 To UBound(Liste)
        If Liste(X, 23) = "Etkin" Then
            Set Tc_Bul = S2.Range("A:A").Find(Liste(X, 2), , , xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 2 To S2.Cells(1, Columns.Count).End(1).Column
                    If WorksheetFunction.CountA(S2.Columns(Y)) - 1 > 0 Then
                        Set Baslik = S1.Rows(1).Find(S2.Cells(1, Y), , , xlWhole)
                        If Not Baslik Is Nothing Then
                            Liste(X, Baslik.Column - 1) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
   
    S1.Range("B2:Z" & UBound(Liste) + 1) = Liste
   
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan hocam kodlar çok güzel çalışıyor lakin veriyi aktardigim Ana sayfadaki formüllerimi siliyor buna bir çözüm bulabilirmiyiz saygilar

Korhan Ayhan · 30 Ekim 2019

Hangi alanda formül var. Detayları vermezseniz nasıl çözüm bulacağız.

Mevcut makroyu hızlandırma

metin_0606

Ekli dosyalar

kemalist

kemalist

Korhan Ayhan

Administrator

metin_0606

metin_0606

metin_0606

metin_0606

kemalist

metin_0606

metin_0606

Ekli dosyalar

Korhan Ayhan

Administrator

metin_0606

metin_0606

metin_0606

Korhan Ayhan

Administrator

metin_0606

metin_0606

metin_0606

Korhan Ayhan

Administrator