Makronun formülleri silmesi

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Kod: 
Option Explicit

Sub Aktar()

'On Error Resume Next

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 = True

Application.Calculation = xlCalculationAutomatic


Set s1 = Sheets("ANA SAYFA")

Set S2 = Sheets("VERI AKTARMA")


Son = s1.Cells(s1.Rows.Count, 3).End(3).Row

liste = s1.Range("A2:AB" & 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) = S2.Cells(Tc_Bul.Row, Y)

End If

End If

Next

End If

End If

Next


s1.Range("A2:AB" & UBound(liste) + 1) = liste


Set Tc_Bul = Nothing

Set Baslik = Nothing

Set s1 = Nothing

Set S2 = Nothing


Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True


MsgBox "Aktarma islemi tamamlanmýstýr." & Chr(10) & Chr(10) & _

"Islem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation

End Sub
Bu makroyu kolon baskılarıni ve TC kimlik numarasını baz alarak sayfalar arası veri aktarmada kullanıyorum. Aktarmada sorun yok ancak veriyi aktardigim sayfada bulunan formülleri de siliyor. Bir türlü çözüm bulamadım. Yardımcı olacak üstat Lara şimdiden teşekkürler
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,742
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Formülleriniz hangi sütunda?
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Mrb Korhan hocam sizin yazmış olduğunuz bir makroydu inşallah yine bir çözüm buluruz U,V,AC sütunlarında
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,742
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek dosyanızı paylşınız.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,742
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ben olayı unuttum.

Neyi nereye neye göre aktarıyorduk?
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Korhan Ayhan' Alıntı:
Ben olayı unuttum.

Neyi nereye neye göre aktarıyorduk?
Genişletmek için tıkla ...
Korhan hocam veri aktarma sayfasına TC kimlik numaralarını yazıp ANA SAYFA isimli sayfada o TC kimlik numaralarını bulup veri aktarma sayfasında hangi başlığın altında veri varsa o bilgileri ANA SAYFA isimli sayfadaki ilgili TC kimlik nonun karşılığında ki başlığın ilgili kısmına aktariyor. Yalnız burada ANA SAYFA ve VERİ AKTARMA sayfalarındaki başlıklar bire bir aynı olacak
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,742
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
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 = True
    Application.Calculation = xlCalculationAutomatic
    
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERI AKTARMA")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Liste = S1.Range("A2:AB" & 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) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    S1.Range("A2:AB" & UBound(Liste) + 1) = Liste
    
    S1.Range("U2:U" & UBound(Liste) + 1).Formula = "=IF(T2="""","""",DAYS360($AD$1,T2))"
    S1.Range("V2:V" & UBound(Liste) + 1).Formula = "=IF(T2="""","""",IF(0>U2,""SÜRESİ DOLDU"","""")&"" ""&IF(U2<30,""(UYARI)"","""")&""""&IF(U2>30,""GEÇERLİ"","""")&"""")"
    S1.Range("AC2:AC" & UBound(Liste) + 1).Formula = "=IF($AB2<>"""",DATEDIF($AB2,TODAY(),""y""),"""")"
    
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Aktarma işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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 = True
    Application.Calculation = xlCalculationAutomatic
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERI AKTARMA")
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Liste = S1.Range("A2:AB" & 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) = S2.Cells(Tc_Bul.Row, Y)
                        End If
                    End If
                Next
            End If
        End If
    Next
   
    S1.Range("A2:AB" & UBound(Liste) + 1) = Liste
   
    S1.Range("U2:U" & UBound(Liste) + 1).Formula = "=IF(T2="""","""",DAYS360($AD$1,T2))"
    S1.Range("V2:V" & UBound(Liste) + 1).Formula = "=IF(T2="""","""",IF(0>U2,""SÜRESİ DOLDU"","""")&"" ""&IF(U2<30,""(UYARI)"","""")&""""&IF(U2>30,""GEÇERLİ"","""")&"""")"
    S1.Range("AC2:AC" & UBound(Liste) + 1).Formula = "=IF($AB2<>"""",DATEDIF($AB2,TODAY(),""y""),"""")"
   
    Set Tc_Bul = Nothing
    Set Baslik = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarma işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...
Korhan hocam çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst