makroyu hızlandırmak

S

selami1982

Katılım
14 Eylül 2020
Mesajlar
56
Excel Vers. ve Dili
2019
Arkadaşlar günaydın,

Aşağıda paylaştığım makroyu kısa yol tuşuna atadım ancak tek tıkla ilgili sayfanın sonuna kadar çalıştırmak istiyorum bunu nasıl revize etmeliyim?

Ayrıca makro çalışmaya hızlı başlıyor ancak yarıya geldikten sonra çok tıkanmalar başlıyor bu performansı arttırabilecek öneriniz var mıdır?

Teşekkürler.

Sub Makro3()
'
' Makro3 Makro
'
' Klavye Kısayolu: Ctrl+Shift+A
'
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-1, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(2, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-3, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(4, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-5, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-2, 2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-1, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(2, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-3, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(4, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-5, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-2, 2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-1, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(2, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-3, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(4, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-5, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-2, 2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-1, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(2, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-3, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(4, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-5, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-2, 2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-1, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(2, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-2, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(3, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-3, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(4, -2).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -3).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-4, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(5, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(-5, 2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(6, -18).Range("A1").Select
End Sub
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Kodları boşverin de siz ne yapmak istiyorsunuz onu anlatın.

Kodlarınızdaki Range("A1") in hiç bir anlamı yok.

O yüzden yapmak istediğinizi açıklayın, ayrıca örnek dosyanızı paylaşım sitelerinden birine yükleyin ve adresini belirtin. Ki daha hızlı yardım alabilesiniz.
 
S

selami1982

Katılım
14 Eylül 2020
Mesajlar
56
Excel Vers. ve Dili
2019

sampleex.xlsx dosyasını indir - download

sampleex.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s7.dosya.tc s7.dosya.tc

Dosyam burda. D sütunundan başlayarak sütundaki verileri makroyla yan taraflara yazdırıyorum.

Çok yavaşlıyor bir noktadan sonra ve hep elle devam ettirmem gerekiyor bekleyip
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Aşağıdaki kodu dener misiniz?
Kod: 
Sub Test()
    Dim Bak As Long
    For Bak = 3 To Cells(Rows.Count, "D").End(xlUp).Row
        If Cells(Bak, "C") = " TW/LW/LYTW" Then
            Range("D" & Bak & ":D" & Bak + 2).Copy
            Cells(Bak, "E").PasteSpecial Paste:=xlValue, Transpose:=True
        End If
    Next
End Sub
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Bu dosyada çalışmayan kısım nedir?
Bu gibi durumlarda sorunu da söylemeniz gerekir.
Aksi halde önce sorunu bulmaya sonra da cevabı bulmaya çalışıyoruz.

Deneyin bakalım sorunu doğru mu tahmin etmişim.
Kod: 
Sub Test()
    Dim Bak As Long
    For Bak = 3 To Cells(Rows.Count, "D").End(xlUp).Row
        If Cells(Bak, "C") = " TW/LW/LYTW" Then
            Range("D" & Bak & ":D" & Bak + 2).Copy
            Cells(Bak, "E").PasteSpecial Transpose:=True
        End If
    Next
End Sub
 
S

selami1982

Katılım
14 Eylül 2020
Mesajlar
56
Excel Vers. ve Dili
2019
Dostum merhaba, paylaştığım dosyada elde etmek istediğim sonucu AAAA bölümünde göstermiştim.

Sizin paylaştığınız şekilde ise sadece 3 satır bilgileri yana geliyor , benimki gibi 8li olmuyor ve dosyanın sonuna kadar devam etmiyor 91. satırda son buluyor.

Ben ise örnekte de paylaştığım gibi her sütun için alt alta 8 satırın yerleşmesini ve tek tıklamayla tüm sayfa işleminin başlayıp bitmesini rica ediyorum

Teşekkürler
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Deneyin.


Kod: 
Sub Test2()
    Dim Bak As Long
    Dim BakSatir As Integer
    For Bak = 3 To Cells(Rows.Count, "D").End(xlUp).Row + 10
        If Cells(Bak, "C") = " TW/LW/LYTW" Then
            Cells(Bak, "E") = Range("D" & Bak)
            Cells(Bak, "F") = Range("D" & Bak + 1)
            Cells(Bak, "G") = Range("D" & Bak + 2)
            
            Cells(Bak + 1, "E") = Range("D" & Bak + 3)
            Cells(Bak + 1, "F") = Range("D" & Bak + 4)
            Cells(Bak + 1, "G") = Range("D" & Bak + 5)
            
            Cells(Bak + 2, "E") = Range("D" & Bak + 6)
            Cells(Bak + 2, "F") = Range("D" & Bak + 7)
            Bak = 7 + Bak
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
 
S

selami1982

Katılım
14 Eylül 2020
Mesajlar
56
Excel Vers. ve Dili
2019
Dostum teşekkürler bu çok daha stabil ve hızlı görünüyor ancak 93. satırda son buluyor. Bunu mevcut dosyada son satır olan 493'te veya yeni gelen dosyalarda son satır kaç ise o satırda sonlandırmak istiyorum. Bu ayarlamayı nasıl dahil edebiliriz?
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Deneyin.
Kod: 
Sub Test2()
    Dim Bak As Long
    Dim BakSatir As Integer
    For Bak = 3 To Cells(Rows.Count, "D").End(xlUp).Row + 10
        If Cells(Bak, "A") <> "" Then
            Cells(Bak, "E") = Range("D" & Bak)
            Cells(Bak, "F") = Range("D" & Bak + 1)
            Cells(Bak, "G") = Range("D" & Bak + 2)
            
            Cells(Bak + 1, "E") = Range("D" & Bak + 3)
            Cells(Bak + 1, "F") = Range("D" & Bak + 4)
            Cells(Bak + 1, "G") = Range("D" & Bak + 5)
            
            Cells(Bak + 2, "E") = Range("D" & Bak + 6)
            Cells(Bak + 2, "F") = Range("D" & Bak + 7)
            Bak = 7 + Bak
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
 
S

selami1982

Katılım
14 Eylül 2020
Mesajlar
56
Excel Vers. ve Dili
2019
Hocam harikasın teşekkürler. Aynı seriyi paralelde de devam ettirmek için

"Cells(Bak, "A") <> "" Then"

Bu kısım altına eklemeler yaparak sonuca varmayı denedim ancak hata aldım. Paralel şekilde de sayfa sonuna kadar kadar nasıl devam ettirebiliriz?

A / B / C / D diye ayrılan 3erli boşlukların da işlem görmesinden bahsediyorum yani.
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Aşağıdaki kodu kullanın.
Kod: 
Sub Test1()
    Dim Bak As Long
    Dim BakSatir As Integer
    Dim Sutun As Integer
    For Bak = 3 To Cells(Rows.Count, "D").End(xlUp).Row + 10
        If Cells(Bak, "A") <> "" Then
            For Sutun = 4 To 16 Step 4
                
                Cells(Bak, Sutun + 1) = Cells(Bak, Sutun)
                Cells(Bak, Sutun + 2) = Cells(Bak + 1, Sutun)
                Cells(Bak, Sutun + 3) = Cells(Bak + 2, Sutun)
                Cells(Bak + 1, Sutun + 1) = Cells(Bak + 3, Sutun)
                Cells(Bak + 1, Sutun + 2) = Cells(Bak + 4, Sutun)
                Cells(Bak + 1, Sutun + 3) = Cells(Bak + 5, Sutun)
                Cells(Bak + 2, Sutun + 1) = Cells(Bak + 6, Sutun)
                Cells(Bak + 2, Sutun + 2) = Cells(Bak + 7, Sutun)
                
            Next
            Bak = 7 + Bak
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
Eğer hücre biçimlendirmeleri de kopyalansın isterseniz aşağıdaki kodu kullanın ancak bu kod çok yavaş çalışır.

Kod: 
Sub Test2()
    Dim Bak As Long
    Dim BakSatir As Integer
    Dim Sutun As Integer
    For Bak = 3 To Cells(Rows.Count, "D").End(xlUp).Row + 10
        If Cells(Bak, "A") <> "" Then
            For Sutun = 4 To 16 Step 4
                
                Cells(Bak, Sutun).Copy Cells(Bak, Sutun + 1)
                Cells(Bak + 1, Sutun).Copy Cells(Bak, Sutun + 2)
                Cells(Bak + 2, Sutun).Copy Cells(Bak, Sutun + 3)
                Cells(Bak + 3, Sutun).Copy Cells(Bak + 1, Sutun + 1)
                Cells(Bak + 4, Sutun).Copy Cells(Bak + 1, Sutun + 2)
                Cells(Bak + 5, Sutun).Copy Cells(Bak + 1, Sutun + 3)
                Cells(Bak + 6, Sutun).Copy Cells(Bak + 2, Sutun + 1)
                Cells(Bak + 7, Sutun).Copy Cells(Bak + 2, Sutun + 2)
                
            Next
            Bak = 7 + Bak
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
 
S

selami1982

Katılım
14 Eylül 2020
Mesajlar
56
Excel Vers. ve Dili
2019
Dediğiniz gibi biçimlendirmeli olanı hata verdi ancak diğeri çok iyi çalışıyor teşekkür ederim.
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Rica ederim. Kolay gelsin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst