Dikey Listede En ucuz Firma Ve Ürünleri Bulma

[umit1907]

Merhabalar,
Aşağı doğru giden bir listemiz var buradaki en uygun firmayı ve ve ürünleri yan sayfaya makro ile nasıl aktarabilirim.

 

[veyselemre]

Sub Makro1()
    With Sheets("En Ucuz")
        .Select
        .Cells.ClearContents
        son = Sheets("Data").Cells(Rows.Count, 1).End(3).Row
        Sheets("Data").Range("A:D").Copy
        .Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        .Columns("A:D").Sort Range("B2"), , Range("D2"), , xlAscending, , , xlYes
        With .Range("E3:E" & son)
            .FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],1,"""")"
            .Value = .Value
            If WorksheetFunction.CountA(.Cells) > 0 Then
                .SpecialCells(xlCellTypeConstants).EntireRow.Delete
            End If
        End With
    End With
End Sub

 

[umit1907]

Teşekkür ederim elinize sağlık.

 

[Ziynettin]

Alternatif, sort edilmeden.

Sub kod()
Set s1 = Sheets("Data")
Set s2 = Sheets("En Ucuz")
son = s1.Cells(Rows.Count, 1).End(3).Row
a = s1.Range("A2:D" & son).Value2
Set d = CreateObject("scripting.dictionary")
d.comparemode = vbTextCompare
    For i = 1 To UBound(a)
        krt = a(i, 2)
        If d.exists(krt) Then
            If a(i, 4) < a(d(krt), 4) Then
                d(krt) = i
            End If
        Else
            d(krt) = i
        End If
    Next i
ReDim b(1 To d.Count, 1 To 4)
    For Each v In d.keys
        say = say + 1
        For j = 1 To 4
            b(say, j) = a(d(v), j)
        Next j
    Next v
s2.[A2].Resize(d.Count, 4) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[umit1907]

Teşekkür Ederim

 

[umit1907]

@veyselemre Bey Çözümünüz için teşekkür ederim. Bu R1C1 formülünün açıklaması nedir böyle bir kaynak varmı.

 

[veyselemre]

Sub adoEnUcuzUrunleriBul()
    strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=NO;IMEX=1"";"

    Set RS = CreateObject("Adodb.RecordSet")

    With Sheets("En Ucuz")
        .Select
        .Range("A2:D" & Rows.Count).ClearContents
        son = Sheets("Data").Cells(Rows.Count, 1).End(3).Row
        STRSQL = "SELECT A.F1, A.F2, A.F3, A.F4 FROM [Data$A2:D" & son & "] A " & _
                 "INNER JOIN " & _
                 "(SELECT F2, Min(F4) AS MN FROM [Data$A2:D" & son & "] GROUP BY F2) B " & _
                 "ON A.F2=B.F2 AND A.F4=B.MN ORDER BY 2"
        RS.Open STRSQL, strcon
        .Range("A2").CopyFromRecordset RS
    End With

    RS.Close
    Set RS = Nothing
End Sub

Sub dicEnUcuzUrunleriBul()
    With Sheets("En Ucuz")
        .Select
        .Range("A2:D" & Rows.Count).ClearContents
        Dim ky As String, ver
        ver = Sheets("Data").Range("A2:D" & Sheets("Data").Cells(Rows.Count, 1).End(3).Row).Value
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(ver)
                ky = ver(i, 2)
                If Not .exists(ky) Then
                    sat = sat + 1
                    .Item(ky) = sat
                    For ii = 1 To 4
                        ver(sat, ii) = ver(i, ii)
                    Next ii
                Else
                    sira = .Item(ky)
                    If ver(sira, 4) > ver(i, 4) Then
                        For ii = 1 To 4
                            ver(sira, ii) = ver(i, ii)
                        Next ii
                    End If
                End If
            Next i
        End With
        .Range("A2").Resize(sat, 4).Value = ver
    End With
End Sub

 

[umit1907]

Teşekkürler @veyselemre bey