• DİKKAT

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

Makro ile kopyalama

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Aynı dosyadaki diğer çalışma sayfalarındaki verileri ilk sayfaya makro ile kopyalama yapılabilir mi ? Örnek Dosya Ektedir.

Teşekkürler.
 

Ekli dosyalar

Şu kodları bir deneyiniz;


Kod: 
Sub Emre()
    Dim i As Integer
    With Sayfa3
        i = .Range("B65536").End(3).Row
        Sayfa2.Range("B5:G1000").ClearContents
        .Range("B5:G" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("I5:N" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("P5:U" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("W5:AB" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
    End With
    i = Empty
End Sub
 
Murat OSMA' Alıntı:
Şu kodları bir deneyiniz;


Kod: 
Sub Emre()
    Dim i As Integer
    With Sayfa3
        i = .Range("B65536").End(3).Row
        Sayfa2.Range("B5:G1000").ClearContents
        .Range("B5:G" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("I5:N" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("P5:U" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("W5:AB" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
    End With
    i = Empty
End Sub
Genişletmek için tıkla ...

Hocam ,

B5 baz alınmış ama B4 e yazıyor.


Sub Emre()
Dim i As Integer
Application.ScreenUpdating = False
Range("B4:G1000").ClearContents
With Sayfa3
i = .Range("B65536").End(3).Row
Sayfa2.Range("B5:G1000").ClearContents
.Range("B5:G" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
.Range("I5:N" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
.Range("P5:U" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
.Range("W5:AB" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
End With
i = Empty
End Sub
 
B5 baz alınmadı...

B4'e bir nokta işareti ya da herhangi bir veri girip tekrar deneyebilirsiniz..
 
Murat OSMA' Alıntı:
Şu kodları bir deneyiniz;


Kod: 
Sub Emre()
    Dim i As Integer
    With Sayfa3
        i = .Range("B65536").End(3).Row
        Sayfa2.Range("B5:G1000").ClearContents
        .Range("B5:G" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("I5:N" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("P5:U" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
        .Range("W5:AB" & i).Copy Sayfa2.Range("B65536").End(3)(2, 1)
    End With
    i = Empty
End Sub
Genişletmek için tıkla ...

Hocam,

SQL VERİ sayfasına verileri manuel yazıp makroyu çalıştırdığımda LİSTE sayfasına sorunsuz getiriyor. SQL sayfasına SQL den veri çağırıp kopyalama makrosunu çalıştırdığımda LİSTEYE SQL sayfasındaki biçimlerle geliyor. Dolayısıyla LİSTE sayfasıda SQL sorgulama sayfası gibi oluyor. Biçimler olmadan kopyalama yapmak için makroda nasıl bir değişim yapmam gerek?
 
Hocam,

SQL VERİ sayfasına verileri manuel yazıp makroyu çalıştırdığımda LİSTE sayfasına sorunsuz getiriyor. SQL sayfasına SQL den veri çağırıp kopyalama makrosunu çalıştırdığımda LİSTEYE SQL sayfasındaki biçimlerle geliyor. Dolayısıyla LİSTE sayfasıda SQL sorgulama sayfası gibi oluyor. Biçimler olmadan kopyalama yapmak için makroda nasıl bir değişim yapmam gerek?
 

Ekli dosyalar

Ekli dosyada tarih sırasında sıralama yapmak için ne yapmam gerek ?
 

Ekli dosyalar

7. sorunun cevabı için kodları şu şekilde bir deneyiniz;

Kod: 
Sub Emre()
    Dim i As Integer
    With Sayfa3
        i = .Range("B65536").End(3).Row
        Sayfa2.Range("B4:G1000").ClearContents
        .Range("B4:G" & i).Copy
        Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial xlValue
        .Range("I4:N" & i).Copy
        Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial xlValue
        .Range("P4:U" & i).Copy
        Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial xlValue
        .Range("W4:AB" & i).Copy
        Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial xlValue
        .Range("AD4:AI" & i).Copy
        Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial xlValue
    End With
    i = Empty
End Sub
 
Sıralama ile ilgili şu kodu kullanabilirsiniz;

Kod: 
Sub Emre()
    Range("B4:G500").Sort Range("D3"), 1
End Sub
 
Sayın Murat Osma,

Hocam,

Verdiğiniz sıralama kodunu ayrı bir makro olarak değilde aşağıdaki koda eklemek istiyorum ama ekleyemedim. Sıralamayı SQL sayfasından verileri aldıktan sonra yaptırmak istiyorum.



'-----------------------------------------------------------
' SQL sayfasındaki verileri listeye almak için
'-----------------------------------------------------------
With Sayfa3
i = .Range("B65536").End(3).Row
Sayfa2.Range("B4:G1000").ClearContents
.Range("B5:G100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("I5:N100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("P5:U100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("W5:AB100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("AD5:AI100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("AK5:AP100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("AR5:AW100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues
.Range("AY5:BD100" & i).Copy
Sayfa2.Range("B65536").End(3)(2, 1).PasteSpecial Paste:=xlPasteValues

End With
i = Empty
'-----------------------------------------------------------
' Listedeki Verileri Tabloya Eklemek için
'-----------------------------------------------------------
a = 12: b = 28: c = 12: d = 28
With Sayfa2
For i = 4 To .Range("B65536").End(3).Row
If .Cells(i, "G") Like "B*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(a, 5).PasteSpecial xlValue
a = a + 1
End If
If .Cells(i, "G") Like "C*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(b, 5).PasteSpecial xlValue
b = b + 1
End If
If .Cells(i, "G") Like "T*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(c, 21).PasteSpecial xlValue
c = c + 1
End If
If .Cells(i, "G") Like "P*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(d, 21).PasteSpecial xlValue
d = d + 1
End If
Next i
End With
i = Empty
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst