• DİKKAT

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

Farklı sutunlarda bulunan para birimlerini tek sutunda yazdırmak

T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,181
Excel Vers. ve Dili
Ofis 2019 Türkçe
Ekli örnek dosyamda açıklamaya çalıştığım gibi Son_fiyat sekmesindeki G,H ve I sutunlarındaki değişik para birimlerini Diğer sayfa olan Butce_calismasi sayfasının M sutununda alt alta, N sunununada Fiayt Sayfasındaki sutun başlıklarındaki Para Birimini yazmasını vba kodu ile yapılmasını istiyorum. Yardımcı olabilecek arkadaşlara şimdiden teşekkür ederim.
 

Ekli dosyalar

C++: 
Sub FiyatVeKur()
With Worksheets("Son_fiyat")
For i = 3 To 7
    Fiyat = 0: Kur = ""
    If .Range("G" & i) > 0 Then Fiyat = .Range("G" & i): Kur = .Range("G2")
    If .Range("H" & i) > Fiyat Then Fiyat = .Range("H" & i): Kur = .Range("H2")
    If .Range("I" & i) > Fiyat Then Fiyat = .Range("I" & i): Kur = .Range("I2")
    Worksheets("Butce_calismasi").Range("M" & i) = Fiyat
    Worksheets("Butce_calismasi").Range("N" & i) = Kur
Next i
End With
End Sub
 
Sn. @ÖmerFaruk Bey çok hızlı bir cevap oldu, orjinal dosyamda uygulayıp geri dönüş yapayım istedim, tam istediğim gibi olmuş çok teşekkür ediyorum, elinize sağlık.
Konu çözüme kavuşmuştur.
 
Sn. @ÖmerFaruk Bey, şimdi dikkatimi çekti, Butce_calısmasi sayfasında Son_fiyat sayfasındaki G,H,I sutunlarını sırasıyla getirdiğini ve Butce_çalışmasındaki A sutunundaki kodların karşılığını getirmediğini farkettim. Ben A sutunundaki kodların karşılığını Son_fiyat sayfasından getirmesini istiyordum. Bakabilirseniz sevinirim.
 
Deneyiniz.

C++: 
Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Zaman As Double
    Dim Veri As Variant, X As Long, Y As Byte, Say As Long
    
    Zaman = Timer
    
    Set S1 = Sheets("Son_fiyat")
    Set S2 = Sheets("Butce_calismasi")
    
    S2.Range("M3:N" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 4 Then Son = 4
    
    Veri = S1.Range("A2:N" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    
    With VBA.CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Veri, 1)
            If Not .Exists(Veri(X, 1)) Then
                Say = Say + 1
                .Add Veri(X, 1), Say
                For Y = 7 To 9
                    If Veri(X, Y) > 0 Then
                        Liste(Say, 1) = Veri(X, Y)
                        Liste(Say, 2) = Veri(1, Y)
                        Exit For
                    End If
                Next
            End If
        Next
    
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        If Son < 4 Then Son = 4
        
        Veri = S2.Range("A3:A" & Son).Value
    
        Say = 0
    
        ReDim Fiyat_Listesi(1 To UBound(Veri, 1), 1 To 2)
    
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            Say = Say + 1
            If .Exists(Veri(X, 1)) Then
                Fiyat_Listesi(Say, 1) = Liste(.Item(Veri(X, 1)), 1)
                Fiyat_Listesi(Say, 2) = Liste(.Item(Veri(X, 1)), 2)
            End If
        Next
    End With
    
    If Say > 0 Then
        S2.Range("M3").Resize(Say, 2) = Fiyat_Listesi
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
End Sub
 
Sn. @Korhan Ayhan Hocam, sizden bir isteğim daha olacak, Son_fiyat sayfasından K sutunundaki tarihe göre en son tarihte alınan aynı ürünün son tarihte alınan ürün fiyatının getirilmesini istiyorum. Yardımlarınız için şimdiden teşekkürler.
 

Ekli dosyalar

Deneyiniz.

C++: 
Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Zaman As Double
    Dim Veri As Variant, X As Long, Y As Byte, Say As Long
   
    Zaman = Timer
   
    Set S1 = Sheets("Son_fiyat")
    Set S2 = Sheets("Butce_calismasi")
   
    S2.Range("M3:N" & S2.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 4 Then Son = 4
   
    Veri = S1.Range("A2:N" & Son).Value
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 3)
   
    With VBA.CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Veri, 1)
            If Not .Exists(Veri(X, 1)) Then
                Say = Say + 1
                .Add Veri(X, 1), Say
                For Y = 7 To 9
                    If Veri(X, Y) > 0 Then
                        Liste(Say, 1) = Veri(X, Y)
                        Liste(Say, 2) = Veri(1, Y)
                        Exit For
                    End If
                Next
                Liste(Say, 3) = IIf(Veri(X, 11) = 0, Date, Veri(X, 11))
            Else
                If IIf(Veri(X, 11) = 0, Date, Veri(X, 11)) > Liste(.Item(Veri(X, 1)), 3) Then
                    For Y = 7 To 9
                        If Veri(X, Y) > 0 Then
                            Liste(.Item(Veri(X, 1)), 1) = Veri(X, Y)
                            Liste(.Item(Veri(X, 1)), 2) = Veri(1, Y)
                            Exit For
                        End If
                    Next
                    Liste(.Item(Veri(X, 1)), 3) = IIf(Veri(X, 11) = 0, Date, Veri(X, 11))
                End If
            End If
        Next
   
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        If Son < 4 Then Son = 4
       
        Veri = S2.Range("A3:A" & Son).Value
   
        Say = 0
   
        ReDim Fiyat_Listesi(1 To UBound(Veri, 1), 1 To 2)
   
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            Say = Say + 1
            If .Exists(Veri(X, 1)) Then
                Fiyat_Listesi(Say, 1) = Liste(.Item(Veri(X, 1)), 1)
                Fiyat_Listesi(Say, 2) = Liste(.Item(Veri(X, 1)), 2)
            End If
        Next
    End With
   
    If Say > 0 Then
        S2.Range("M3").Resize(Say, 2) = Fiyat_Listesi
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
End Sub
 
Sn. @Korhan Ayhan hocam, pc başına yeni geçtim, cevabınız için çok teşekkür ediyorum, Tam istediğim gibi olmuş, Son_fiyat sayfasında tarihi boş olanlara (henüz fatura kesilmediğinden) Bu günün tarihini (yani işlem aypığımız andaki tarihi yazdırabilirsek, harika olur. İlgilendiğiniz için çok teşekkür ediyorum. Saygılar
 
Eski bir üyemizsiniz. Bahsettiğiniz son işlemi filtre metodu ile sizde kolaylıkla yapabilirsiniz.
 
Sn. @Korhan Ayhan Hocam, sizin kodların içinde getirmek gerekiyor, çünkü tarihi olmayanların bir önceki son tarihinin fiyatını getiriyor, benim yaptığım diğer makroları (başka işlemler yapan) da sizin kodun altında çalıştırıp tek tık ile sonuca gitmek istemiştim.

Yada K sutununda bulunan ve 0.01.1900 formatında görünen tarihi Bugünün tarihi ile yazdırabilirsek de benim işimi görecektir.
 
Son düzenleme:
#9 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.
 
Sn. @Korhan Ayhan Hocam, aynı ürünlerin son tarih fiyatını getirmiyor, ikinci tarihte olan fiyatları getiriyor. Örnek dosyayı gönderiyorum. Sizleri de yordum hakkınızı helal edin.
 

Ekli dosyalar

Kodu tekrar revize ettim. Deneyiniz.
 
Korhan Hocam çok teşekkür ediyorum, hakkınızı helal edin, Şimdi tam istediğim gibi oldu. Elinize Sağlık. Hayırlı geceler diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst