Filtreli Veriyi Kopyalama Yapıştır

[emiroglu07]

Ü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.

 

[emiroglu07]

pardon flitreye göre kopyalamaıyor

 

[ÖmerBey]

bu makro değer olarak kaydetmiyor DEĞER olarak kaydetmeyi nasıl sağlıyabiliriz.

Merhaba,
rng2.PasteSpecial xlPasteValues
şeklinde deneyiniz.

 

[emiroglu07]

Ü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]

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.

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...

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

 

[emiroglu07]

üstad yapmış olduğunuz makro olmadı ben kulladığım örnek dosayı ekliyorum size daha iyi bilgi verir.

İndir deneme

Dosyayı indir deneme

dosya.co

 

[ÖmerBey]

Paylaştığım alternatif kodu denediniz mi?
Yoksa yine de kullandığınız kodu düzenlememi mi istiyorsunuz?

 

[emiroglu07]

Ustad alternatif kodu denedim oda hata verdi bremis oldugum excel dosyasina bakarsaniz hatali kopyalama yapoyor

 

[ÖmerBey]

Ben filtreli veriyi başka bir yere kopyalayacaksınız diye düşünmüştüm.
Aşağıdaki şekilde dener misiniz?

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

 

[emiroglu07]

Ü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.

 

[HücrelereFısıldayanAdam]

...