Sadece Değerleri Kopyala

[baydeniro]

Merhaba Arkadaşlar,
A1 hücresinde yazılı kritere göre DATA sayfasından çekeceği verilere sadece DEĞER olarak RAPOR sayfasına aktarmak mümkün mü ?

 

[ToHaNS]

Olayı tam doğru anlamamış olabilirim. Malum saat epey geç oldu

Sub vericek()
Dim SSData, SSRapor, x, y, buldum As Long, Data, Rapor As Worksheet
Set Data = Sheets("DATA")
Set Rapor = Sheets("RAPOR")
Application.ScreenUpdating = False
SSData = Data.Cells(Rows.Count, 3).End(xlUp).Row
SSRapor = Rapor.Cells(Rows.Count, 1).End(xlUp).Row
buldum = 1
Rapor.Range("A2:C" & SSRapor).Value = Empty

For x = 2 To SSData
If Data.Range("A" & x).Value = Empty Then Exit Sub
If Rapor.Range("A1").Value = Data.Range("A" & x).Value And Data.Range("B" & x).Value = "var" Then
      buldum = buldum + 1
      For y = 1 To 3
      Rapor.Cells(buldum, y).Value = Data.Cells(x, y).Value
      Next
End If
Next
Rapor.Range("A2:C" & SSRapor).Sort key1:=Cells(1, 3), order1:=xlDescending, Header:=xlNo
Application.ScreenUpdating = True
End Sub

 

[baydeniro]

Olayı tam doğru anlamamış olabilirim. Malum saat epey geç oldu

Sub vericek()
Dim SSData, SSRapor, x, y, buldum As Long, Data, Rapor As Worksheet
Set Data = Sheets("DATA")
Set Rapor = Sheets("RAPOR")
Application.ScreenUpdating = False
SSData = Data.Cells(Rows.Count, 3).End(xlUp).Row
SSRapor = Rapor.Cells(Rows.Count, 1).End(xlUp).Row
buldum = 1
Rapor.Range("A2:C" & SSRapor).Value = Empty

For x = 2 To SSData
If Data.Range("A" & x).Value = Empty Then Exit Sub
If Rapor.Range("A1").Value = Data.Range("A" & x).Value And Data.Range("B" & x).Value = "var" Then
      buldum = buldum + 1
      For y = 1 To 3
      Rapor.Cells(buldum, y).Value = Data.Cells(x, y).Value
      Next
End If
Next
Rapor.Range("A2:C" & SSRapor).Sort key1:=Cells(1, 3), order1:=xlDescending, Header:=xlNo
Application.ScreenUpdating = True
End Sub

İlginize çok teşekkür ederim. Güzel bir koda benziyor ama RAPOR sayfasında kriterin belirtildiği A1 hücresini siliyor.

 

[ToHaNS]

Dosyayı inceler misiniz?

 

[baydeniro]

Dosyayı inceler misiniz?

Üstad çok teşekkürler. Sizdeki dosyada KİRAZ seçip kodu çalıştırır mısınız

 

[ToHaNS]

Kiraz'ı seçip Düğme 4'ü çalıştırdım. Normal şekilde çalıştı üstadım. A1 hücresine herhangi bir müdahalesi olmadı.

 

[baydeniro]

Ekli dosyayı görüntüle 229014


Kiraz'ı seçip Düğme 4'ü çalıştırdım. Normal şekilde çalıştı üstadım. A1 hücresine herhangi bir müdahalesi olmadı.

Üstad ilgine teşekkür ediyorum. Kirazı belirtmemin nedeni, 2 tane KİRAZ var, 1 tane geliyor !

 

[ToHaNS]

Sadece stok durumu "var" olanları getiriyor. Stok durumu var olan kiraz 1 satırda olduğu için sadece onu getiriyor hocam. Diğerinde Kalmadı yerine "var" yazarsanız onu da dahil edecektir.

 

[Korhan Ayhan]

Alternatif;

ADO uygulaması;

Option Explicit

Sub Aktar()
    Dim Baglanti As Object, Kayit_Seti As Object
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    Set Kayit_Seti = Baglanti.Execute("Select * From [DATA$A:C] Where [Ürün] = '" & Sheets("RAPOR").Range("A1").Value & "'")
    
    With Sheets("RAPOR")
        .Range("A2:C" & .Rows.Count).ClearContents
        .Range("A2").CopyFromRecordset Kayit_Seti
    End With
    
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[baydeniro]

Alternatif;

ADO uygulaması;

Option Explicit

Sub Aktar()
    Dim Baglanti As Object, Kayit_Seti As Object
   
    Set Baglanti = CreateObject("AdoDb.Connection")
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

    Set Kayit_Seti = Baglanti.Execute("Select * From [DATA$A:C] Where [Ürün] = '" & Sheets("RAPOR").Range("A1").Value & "'")
   
    With Sheets("RAPOR")
        .Range("A2:C" & .Rows.Count).ClearContents
        .Range("A2").CopyFromRecordset Kayit_Seti
    End With
   
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
   
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Üstad çok teşekkürler. Şurada hata verdi !

Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""

 

[baydeniro]

Sadece stok durumu "var" olanları getiriyor. Stok durumu var olan kiraz 1 satırda olduğu için sadece onu getiriyor hocam. Diğerinde Kalmadı yerine "var" yazarsanız onu da dahil edecektir.

ToHaNS ilgine çok çok teşekkür ediyorum. Kodu henüz deneme fırsatı buldum. Harika olmuş, elinize sağlık. Sağlıcakla kalın

 

[Korhan Ayhan]

Verdiği hata mesajı nedir?

 

[baydeniro]

Verdiği hata mesajı nedir?

Üstad merhaba, kusura bakmayın, anlık bir durumdu galiba. Şimdi gayet güzel çalışıyor. Çok teşekkür ediyorum, sağlıcakla kalın