..:: Makro ile Veri Alma ::..

[Lecay]

Arkadaşlar merhaba,

Sheet1'deki nakliye numalarının yanına Sheet2'deki öncelikleri sıralamalarına göre makro ile çekmek istiyorum. Eğer bir nakliyede çok acil önceliği mevcut ise Çok acil yaz. 1 öncelik yoksa 2. öncelik varsa Acil yaz. 1 ve 2 yoksa 3 varsa Öncelikli yaz. Bu 3'ü yoksa Normal yaz demek istiyorum. Yardım edebilirmisiniz ?
Öncelik:
1. Çok Acil
2. Acil
3. Öncelikli
4. Normal

 

[Emir Hüseyin Çoban]

.

Sheet2' de aynı nakliye numarası için farklı tanımlamalar var. Hangisini getirmesi gerekiyor.
Sheet1' e isim mi yazacak, rakam mı.

.

 

[Lecay]

Evet evet doğru. Bir nakliye içerisinde belirttiğim gibi 4 öncelikte olabilir fakat sırasına göre yazdırmak istiyorum

 

[Emir Hüseyin Çoban]

.

Sayfa1' i örneğinize göre doldurabilir misiniz.

.

 

[Lecay]

Buyrunnnnn

 

[Ziynettin]

Deneyiniz.

Option Explicit
Sub kosullu_ara()
Dim s1 As Worksheet, S2 As Worksheet
Dim a(), b(), c(), d As Object, deg, tbl()
Dim i As Long, x As Long, Say As Long
Set s1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("C3:C" & s1.Cells(Rows.Count, "C").End(3).Row)
b = s1.Range("J2:J" & s1.Cells(Rows.Count, "J").End(3).Row)
c = S2.Range("B3:C" & S2.Cells(Rows.Count, "B").End(3).Row)
ReDim k(1 To UBound(c), 1 To 2)
    For i = 1 To UBound(b)
        For x = 1 To UBound(c)
            If Trim(c(x, 2)) = Trim(b(i, 1)) Then
                deg = c(x, 1) & c(x, 2)
                If Not d.exists(deg) Then
                    Say = Say + 1
                    d(deg) = Say
                    k(Say, 1) = c(x, 1)
                    k(Say, 2) = c(x, 2)
                End If
            End If
        Next x
    Next i
tbl = Array(k)
ReDim m(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        For x = d.Count To 1 Step -1
            If a(i, 1) = tbl(0)(x, 1) Then
                m(i, 1) = tbl(0)(x, 2)
            End If
        Next x
    Next i
s1.Range("D3").Resize(UBound(a)) = m
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[Lecay]

Hocam kod çalışıyor, ellerinize sağlık.
Bu kodu kendi çalışmama uyarlayamadım yanlız yardım edebilirmisiniz ? YUSD_SHP004 sayfasındaki önceliği sıralamasına göre FTL_Plan sayfasındaki "C" sütununa yazdırmak istiyorum

 

[Ziynettin]

#7. mesajdaki ekli dosyanız için,

Sub Sartli_ara()
Dim s1 As Worksheet, S2 As Worksheet, s3 As Worksheet
Dim a(), b(), c(), d As Object, deg, tbl()
Dim i As Long, x As Long, Say As Long

Set s1 = Sheets("FTL_Plan")
Set S2 = Sheets("YUSD_SHP004")
Set s3 = Sheets("MASTER")

Set d = CreateObject("scripting.dictionary")
a = s1.Range("D3:D" & s1.Cells(Rows.Count, "D").End(3).Row)
b = s3.[Q8:Q11].Value
c = S2.Range("B2:L" & S2.Cells(Rows.Count, "B").End(3).Row)

ReDim k(1 To UBound(c), 1 To 2)
    For i = 1 To UBound(b)
        For x = 1 To UBound(c)
            If Trim(c(x, 11)) = Trim(b(i, 1)) Then
                deg = c(x, 1) & c(x, 11)
                If Not d.exists(deg) Then
                    Say = Say + 1
                    d(deg) = Say
                    k(Say, 1) = c(x, 1)
                    k(Say, 2) = c(x, 11)
                End If
            End If
        Next x
    Next i
tbl = Array(k)
ReDim m(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        For x = d.Count To 1 Step -1
            If a(i, 1) = tbl(0)(x, 1) Then
                m(i, 1) = tbl(0)(x, 2)
            End If
        Next x
    Next i
s1.Range("C3").Resize(UBound(a)) = m
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[Lecay]

Ziynettin hocam harikasın, çok teşekkür ederim

 

[Lecay]

Ziynettin hocam, 1'den fazla nakliye için makro çalışıyor fakat 1 nakliyede makro çalışmıyor. Neden olabilir sizce ?

 

[Ziynettin]

......

Option Explicit
Sub kosullu_ara()
Dim s1 As Worksheet, S2 As Worksheet
Dim a(), b(), c(), d As Object, deg, tbl()
Dim i As Long, x As Long, Say As Long, Son As Long
Set s1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
Set d = CreateObject("scripting.dictionary")
On Error Resume Next
Son = s1.Cells(Rows.Count, "C").End(3).Row
If Son <= 3 Then Son = Son + 1
a = s1.Range("C3:C" & Son)
b = s1.Range("J2:J" & s1.Cells(Rows.Count, "J").End(3).Row)
c = S2.Range("B3:C" & S2.Cells(Rows.Count, "B").End(3).Row)
ReDim k(1 To UBound(c), 1 To 2)
    For i = 1 To UBound(b)
        For x = 1 To UBound(c)
            If Trim(c(x, 2)) = Trim(b(i, 1)) Then
                deg = c(x, 1) & c(x, 2)
                If Not d.exists(deg) Then
                    Say = Say + 1
                    d(deg) = Say
                    k(Say, 1) = c(x, 1)
                    k(Say, 2) = c(x, 2)
                End If
            End If
        Next x
    Next i
tbl = Array(k)
ReDim m(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        For x = d.Count To 1 Step -1
            If a(i, 1) = tbl(0)(x, 1) Then
                m(i, 1) = tbl(0)(x, 2)
            End If
        Next x
    Next i
s1.Range("D3").Resize(UBound(a)) = m
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[Lecay]

Klavyenin "." harfi basılı kaldı sanırım.

Yardımınız için teşekkürler