• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

makroda nasıl kısaltma yapabilirim.

A

abbasonline

Katılım
8 Mart 2009
Mesajlar
504
Excel Vers. ve Dili
2010
ub Bul_Getir()

Dim i As Long, _
j As Long, _
c As Range, _
Adr As String, _
sv As Worksheet, _
sa As Worksheet
Set sv = Sheets("2011")
Set sa = Sheets("ARAMA")
sa.Select

i = sv.Cells(Rows.Count, "A").End(3).Row
If i < 7 Then i = 7
j = sa.Cells(Rows.Count, "E").End(3).Row
If j < 8 Then j = 8
sa.Range("B8:CR" & j).ClearContents
j = 7

With sv.Range("E7:E" & i)
Set c = .Find(sa.Range("A7"), LookIn:=xlValues)
If Not c Is Nothing Then
Adr = c.Address
Do
j = j + 1
sa.Cells(j, "B") = sv.Range("A" & c.Row)
sa.Cells(j, "C") = sv.Range("C" & c.Row)
sa.Cells(j, "D") = sv.Range("D" & c.Row)
sa.Cells(j, "E") = sv.Range("E" & c.Row)
sa.Cells(j, "F") = sv.Range("G" & c.Row)
sa.Cells(j, "G") = sv.Range("H" & c.Row)
sa.Cells(j, "H") = sv.Range("I" & c.Row)
sa.Cells(j, "I") = sv.Range("J" & c.Row)
sa.Cells(j, "J") = sv.Range("K" & c.Row)
sa.Cells(j, "K") = sv.Range("L" & c.Row)
sa.Cells(j, "L") = sv.Range("M" & c.Row)
sa.Cells(j, "M") = sv.Range("N" & c.Row)
sa.Cells(j, "N") = sv.Range("O" & c.Row)
sa.Cells(j, "O") = sv.Range("P" & c.Row)
sa.Cells(j, "P") = sv.Range("Q" & c.Row)
sa.Cells(j, "Q") = sv.Range("R" & c.Row)
sa.Cells(j, "R") = sv.Range("S" & c.Row)
sa.Cells(j, "S") = sv.Range("T" & c.Row)
sa.Cells(j, "T") = sv.Range("U" & c.Row)
sa.Cells(j, "U") = sv.Range("V" & c.Row)
sa.Cells(j, "V") = sv.Range("W" & c.Row)
sa.Cells(j, "W") = sv.Range("X" & c.Row)
sa.Cells(j, "X") = sv.Range("Y" & c.Row)
sa.Cells(j, "Y") = sv.Range("Z" & c.Row)
sa.Cells(j, "Z") = sv.Range("AA" & c.Row)
sa.Cells(j, "AA") = sv.Range("AB" & c.Row)
sa.Cells(j, "AB") = sv.Range("AC" & c.Row)
sa.Cells(j, "AC") = sv.Range("AD" & c.Row)
sa.Cells(j, "AD") = sv.Range("AE" & c.Row)
sa.Cells(j, "AE") = sv.Range("AF" & c.Row)
sa.Cells(j, "AF") = sv.Range("AG" & c.Row)
sa.Cells(j, "AG") = sv.Range("AH" & c.Row)
sa.Cells(j, "AH") = sv.Range("AI" & c.Row)
sa.Cells(j, "AI") = sv.Range("AJ" & c.Row)
sa.Cells(j, "AJ") = sv.Range("AK" & c.Row)
sa.Cells(j, "AK") = sv.Range("AL" & c.Row)
sa.Cells(j, "AL") = sv.Range("AM" & c.Row)
sa.Cells(j, "AM") = sv.Range("AN" & c.Row)
sa.Cells(j, "AN") = sv.Range("AO" & c.Row)
sa.Cells(j, "AO") = sv.Range("AP" & c.Row)
sa.Cells(j, "AP") = sv.Range("AQ" & c.Row)
sa.Cells(j, "AQ") = sv.Range("AR" & c.Row)
sa.Cells(j, "AR") = sv.Range("AS" & c.Row)
sa.Cells(j, "AS") = sv.Range("AT" & c.Row)
sa.Cells(j, "AT") = sv.Range("AU" & c.Row)
sa.Cells(j, "AU") = sv.Range("AV" & c.Row)
sa.Cells(j, "AV") = sv.Range("AW" & c.Row)
sa.Cells(j, "AW") = sv.Range("AX" & c.Row)
sa.Cells(j, "AX") = sv.Range("AY" & c.Row)
sa.Cells(j, "AY") = sv.Range("AZ" & c.Row)
sa.Cells(j, "AZ") = sv.Range("BA" & c.Row)
sa.Cells(j, "BA") = sv.Range("BB" & c.Row)
sa.Cells(j, "BB") = sv.Range("BC" & c.Row)
sa.Cells(j, "BC") = sv.Range("BD" & c.Row)
sa.Cells(j, "BD") = sv.Range("BE" & c.Row)
sa.Cells(j, "BE") = sv.Range("BF" & c.Row)
sa.Cells(j, "BF") = sv.Range("BG" & c.Row)
sa.Cells(j, "BG") = sv.Range("BH" & c.Row)
sa.Cells(j, "BH") = sv.Range("BI" & c.Row)
sa.Cells(j, "BI") = sv.Range("BJ" & c.Row)
sa.Cells(j, "BJ") = sv.Range("BK" & c.Row)
sa.Cells(j, "BK") = sv.Range("BL" & c.Row)
sa.Cells(j, "BL") = sv.Range("BM" & c.Row)
sa.Cells(j, "BM") = sv.Range("BN" & c.Row)
sa.Cells(j, "BN") = sv.Range("BO" & c.Row)
sa.Cells(j, "BO") = sv.Range("BP" & c.Row)
sa.Cells(j, "BP") = sv.Range("BQ" & c.Row)
sa.Cells(j, "BQ") = sv.Range("BR" & c.Row)
sa.Cells(j, "BR") = sv.Range("BS" & c.Row)
sa.Cells(j, "BS") = sv.Range("BT" & c.Row)
sa.Cells(j, "BT") = sv.Range("BU" & c.Row)
sa.Cells(j, "BU") = sv.Range("BV" & c.Row)
sa.Cells(j, "BV") = sv.Range("BW" & c.Row)
sa.Cells(j, "BW") = sv.Range("BX" & c.Row)
sa.Cells(j, "BX") = sv.Range("BY" & c.Row)
sa.Cells(j, "BY") = sv.Range("BZ" & c.Row)
sa.Cells(j, "BZ") = sv.Range("CA" & c.Row)
sa.Cells(j, "CA") = sv.Range("CB" & c.Row)
sa.Cells(j, "CB") = sv.Range("CC" & c.Row)
sa.Cells(j, "CC") = sv.Range("CD" & c.Row)
sa.Cells(j, "CD") = sv.Range("CE" & c.Row)
sa.Cells(j, "CE") = sv.Range("CF" & c.Row)
sa.Cells(j, "CF") = sv.Range("CG" & c.Row)
sa.Cells(j, "CG") = sv.Range("CH" & c.Row)
sa.Cells(j, "CH") = sv.Range("CI" & c.Row)
sa.Cells(j, "CI") = sv.Range("CJ" & c.Row)
sa.Cells(j, "CJ") = sv.Range("CK" & c.Row)
sa.Cells(j, "CK") = sv.Range("CL" & c.Row)
sa.Cells(j, "CL") = sv.Range("CM" & c.Row)
sa.Cells(j, "CM") = sv.Range("CN" & c.Row)
sa.Cells(j, "CN") = sv.Range("CO" & c.Row)
sa.Cells(j, "CO") = sv.Range("CP" & c.Row)
sa.Cells(j, "CP") = sv.Range("CQ" & c.Row)
sa.Cells(j, "CQ") = sv.Range("CR" & c.Row)
sa.Cells(j, "CR") = sv.Range("CS" & c.Row)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With

End Sub









üsteki makro ile excel kitapcığı 300 Mb yaklaşıyor veriler ile birlikte ve tabiki kitabcığın açılması bayağı geç oluyor bunu nasıl kısaltabilirim ek deki dosya ya uyarlamıştım.
 

Ekli dosyalar

abbasonline' Alıntı:
ub Bul_Getir()


üsteki makro ile excel kitapcığı 300 Mb yaklaşıyor veriler ile birlikte ve tabiki kitabcığın açılması bayağı geç oluyor bunu nasıl kısaltabilirim ek deki dosya ya uyarlamıştım.
Genişletmek için tıkla ...

Makro kodunun kısaltılması için aşağıdaki kodu denermisiniz.

Kod: 
Sub Bul_Getir()
Dim i As Long, j As Long, K As Long
Dim c As Range, Adr As String
Dim sv As Worksheet, sa As Worksheet
Set sv = Sheets("2011")
Set sa = Sheets("ARAMA")
sa.Select
i = sv.Cells(Rows.Count, "A").End(3).Row
If i < 7 Then i = 7
j = sa.Cells(Rows.Count, "E").End(3).Row
If j < 8 Then j = 8
sa.Range("B8:CR" & j).ClearContents
j = 7
With sv.Range("E7:E" & i)
Set c = .Find(sa.Range("A7"), LookIn:=xlValues)
If Not c Is Nothing Then
Adr = c.Address
Do
j = j + 1
sa.Cells(j, "B") = sv.Cells(c.Row, "A")
sa.Cells(j, "C") = sv.Cells(c.Row, "C")
sa.Cells(j, "D") = sv.Cells(c.Row, "D")
sa.Cells(j, "E") = sv.Cells(c.Row, "E")
For K = 6 To 96
sa.Cells(j, [COLOR=red]K[/COLOR]) = sv.Cells(c.Row, K + 1)
[COLOR=red]next[/COLOR]
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
End Sub
 
Sub Bul_Getir()
Dim i As Long, j As Long, K As Long
Dim c As Range, Adr As String
Dim sv As Worksheet, sa As Worksheet
Set sv = Sheets("2011")
Set sa = Sheets("ARAMA")
sa.Select
i = sv.Cells(Rows.Count, "A").End(3).Row
If i < 7 Then i = 7
j = sa.Cells(Rows.Count, "E").End(3).Row
If j < 8 Then j = 8
sa.Range("B8:CR" & j).ClearContents
j = 7
With sv.Range("E7:E" & i)
Set c = .Find(sa.Range("A7"), LookIn:=xlValues)
If Not c Is Nothing Then
Adr = c.Address
Do
j = j + 1
sa.Cells(j, "B") = sv.Cells(c.Row, "A")
sa.Cells(j, "C") = sv.Cells(c.Row, "C")
sa.Cells(j, "D") = sv.Cells(c.Row, "D")
sa.Cells(j, "E") = sv.Cells(c.Row, "E")
For K = 6 To 96
sa.Cells(j, 6) = sv.Cells(c.Row, K + 1)
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
End Sub






alttan 6. satırdaki (kırmızı) End if sarı olup hata veriyor.
 
abbasonline' Alıntı:
Sub Bul_Getir()
Dim i As Long, j As Long, K As Long
Dim c As Range, Adr As String
Dim sv As Worksheet, sa As Worksheet
Set sv = Sheets("2011")
Set sa = Sheets("ARAMA")
sa.Select
i = sv.Cells(Rows.Count, "A").End(3).Row
If i < 7 Then i = 7
j = sa.Cells(Rows.Count, "E").End(3).Row
If j < 8 Then j = 8
sa.Range("B8:CR" & j).ClearContents
j = 7
With sv.Range("E7:E" & i)
Set c = .Find(sa.Range("A7"), LookIn:=xlValues)
If Not c Is Nothing Then
Adr = c.Address
Do
j = j + 1
sa.Cells(j, "B") = sv.Cells(c.Row, "A")
sa.Cells(j, "C") = sv.Cells(c.Row, "C")
sa.Cells(j, "D") = sv.Cells(c.Row, "D")
sa.Cells(j, "E") = sv.Cells(c.Row, "E")
For K = 6 To 96
sa.Cells(j, K) = sv.Cells(c.Row, K + 1)
next
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
End Sub






alttan 6. satırdaki (kırmızı) End if sarı olup hata veriyor.
Genişletmek için tıkla ...

Bir yanlışlık olmuş End If yerine next olarak değiştirin.
 
düzeldi teşekkürler veri sayfasının ismini yanlış yazmışım teşekkürler kolay gelsin
 
tekrar hata oldu dikkat etmemişim sadece( A,C,E) VE (CS) SÜTUNLARINDAKİ VERİLERİ ARAMA sayfasına getiriyor aradaki bazı sütunlarda da veri var onları getirmiyor.
 
2 nolu mesajda kırmızı yeri değiştirin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst