Farklı sutunlarda bulunan para birimlerini tek sutunda yazdırmak

tahsinanarat · 24 Eylül 2021

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.

ÖmerFaruk · 24 Eylül 2021

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

tahsinanarat · 24 Eylül 2021

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.

tahsinanarat · 24 Eylül 2021

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.

tahsinanarat · 24 Eylül 2021

Konu güncel

Korhan Ayhan · 24 Eylül 2021

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

tahsinanarat · 24 Eylül 2021

sn. @Korhan Ayhan hocam, tam istediğim gibi oldu elinize sağlık, çok teşekkür ederim. Saygılar.

tahsinanarat · 25 Eylül 2021

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.

Korhan Ayhan · 25 Eylül 2021

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

tahsinanarat · 25 Eylül 2021

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

Korhan Ayhan · 25 Eylül 2021

Eski bir üyemizsiniz. Bahsettiğiniz son işlemi filtre metodu ile sizde kolaylıkla yapabilirsiniz.

tahsinanarat · 25 Eylül 2021

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.

Korhan Ayhan · 26 Eylül 2021

#9 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

tahsinanarat · 26 Eylül 2021

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.

Korhan Ayhan · 26 Eylül 2021

Kodu tekrar revize ettim. Deneyiniz.

tahsinanarat · 26 Eylül 2021

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.

Farklı sutunlarda bulunan para birimlerini tek sutunda yazdırmak

tahsinanarat

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

tahsinanarat

tahsinanarat

tahsinanarat

Korhan Ayhan

Administrator

tahsinanarat

tahsinanarat

Ekli dosyalar

Korhan Ayhan

Administrator

tahsinanarat

Korhan Ayhan

Administrator

tahsinanarat

Korhan Ayhan

Administrator

tahsinanarat

Ekli dosyalar

Korhan Ayhan

Administrator

tahsinanarat