Filtreli Veriyi Kopyalama Yapıştır

Katılım
4 Mayıs 2013
Mesajlar
79
Excel Vers. ve Dili
office 2010
Üstad ihtiyacımdan dolayı flitreli veriyi kopyalama yapıştırma makrosu aradım durdum baktım ki birçok arkadaşımızda bu konudan müzdarip bende elimdeki kodu paylaşmak hemde bir konu hakkında sizden bilgi almak istiyorum.

Sub CopyFilteredCells()
'Updateby20150203
Dim rng1 As Range
Dim rng2 As Range
Dim InputRng As Range
Dim OutRng As Range
xTitleId = "FİLİTRELİ VERİYİ KOPYALA YAPIŞTIR"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
For Each rng1 In InputRng
rng1.Copy
For Each rng2 In OutRng
If rng2.EntireRow.RowHeight > 0 Then
rng2.PasteSpecial
Set OutRng = rng2.Offset(1).Resize(OutRng.Rows.Count)
Exit For
End If
Next
Next
Application.CutCopyMode = False
End Sub

bu makro değer olarak kaydetmiyor DEĞER olarak kaydetmeyi nasıl sağlıyabiliriz.
 
Katılım
4 Mayıs 2013
Mesajlar
79
Excel Vers. ve Dili
office 2010
Üstad dediğiniz gibi oldu teşekkür ederim ama daha büyük bir sorun var flitreye göre kopyalayıp yapıştırmıyor
mesala a1 a7 a9 a11 a23 flitreli MAKRO a1:a23 yapıp kopyalıyor buda bizim için sıkıntı makroyu kullanamıyorum
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,162
Excel Vers. ve Dili
2007 Türkçe
Gördüğüm kadarıyla if sorgusunu ters değere yaptırıyorsunuz.
Deneme imkanım olmadığı için denemeden yazıyorum başka sorunlar da çıkabilir.
Kod:
Sub CopyFilteredCells()
'Updateby20150203
Dim rng1 As Range
Dim rng2 As Range
Dim InputRng As Range
Dim OutRng As Range
xTitleId = "FİLİTRELİ VERİYİ KOPYALA YAPIŞTIR"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
For Each rng1 In InputRng
If rng1.EntireRow.RowHeight > 0 Then
    rng1.Copy
    For Each rng2 In OutRng
        rng2.PasteSpecial xlPasteValues
        Set OutRng = rng2.Offset(1).Resize(OutRng.Rows.Count)
        Exit For
    Next
End If
Next
Application.CutCopyMode = False
End Sub
Alternatif olarak aşağıdaki kodu deneyiniz, daha pratik çalışacaktır...
Kod:
Sub kod()
Dim InputRng As Range
Dim OutRng As Range
xTitleId = "FİLİTRELİ VERİYİ KOPYALA YAPIŞTIR"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
InputRng.SpecialCells(xlCellTypeVisible).Copy
OutRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
End Sub
 
Katılım
4 Mayıs 2013
Mesajlar
79
Excel Vers. ve Dili
office 2010
üstad yapmış olduğunuz makro olmadı ben kulladığım örnek dosayı ekliyorum size daha iyi bilgi verir.

 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,162
Excel Vers. ve Dili
2007 Türkçe
Paylaştığım alternatif kodu denediniz mi?
Yoksa yine de kullandığınız kodu düzenlememi mi istiyorsunuz?
 
Katılım
4 Mayıs 2013
Mesajlar
79
Excel Vers. ve Dili
office 2010
Ustad alternatif kodu denedim oda hata verdi bremis oldugum excel dosyasina bakarsaniz hatali kopyalama yapoyor
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,162
Excel Vers. ve Dili
2007 Türkçe
Ben filtreli veriyi başka bir yere kopyalayacaksınız diye düşünmüştüm.
Aşağıdaki şekilde dener misiniz?
Kod:
Sub CopyFilteredCells()
'Updateby20150203
Dim rng1 As Range
Dim rng2 As Range
Dim InputRng As Range
Dim OutRng As Range
Dim x As Integer
xTitleId = "FİLİTRELİ VERİYİ KOPYALA YAPIŞTIR"
Set InputRng = Application.Selection
1
Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
If InputRng.SpecialCells(xlCellTypeVisible).Cells.Count <> OutRng.SpecialCells(xlCellTypeVisible).Cells.Count Then
    MsgBox "Uyumlu seçim yapmadınız." & vbLf & "Yeniden seçim yapınız", vbCritical
    GoTo 1
End If
ReDim dz(0)
x = 0
For Each rng1 In InputRng
    If rng1.EntireRow.RowHeight > 0 Then
        ReDim Preserve dz(x)
        dz(x) = rng1.Value
        x = x + 1
    End If
Next
x = 0
For Each rng2 In OutRng
    If rng2.EntireRow.RowHeight > 0 Then
        rng2.Value = dz(x)
        x = x + 1
    End If
Next
Application.CutCopyMode = False
End Sub
 
Katılım
4 Mayıs 2013
Mesajlar
79
Excel Vers. ve Dili
office 2010
Üstad ellerine sağlık tam istediğim gibi olmuş Rabbim işini gücünü Rast getirsin Vallahi beni büyük bir dertten kurtardın.
 
Son düzenleme:
Üst