Tablodaki iller karşısındaki meyve ve sebzelerin alt alta toplanması

[ocak26]

Merhaba Arkadaşlar
İlgili tabloyla ilgilenirseniz sevinirim.
Teşekkürler

 

[antonio]

Aşağıdaki kodu deneyin.

Sub listele()
Dim s1 As Worksheet, s2 As Worksheet, ss As Long, sat As Integer
Set s1 = Sayfa1
Set s2 = Sayfa2
ss = s1.Range("C" & Rows.Count).End(3).Row
sat = 3
s2.Range("A3:C" & Rows.Count).ClearContents
For i = 3 To ss
    s2.Cells(sat, 1).Value = s1.Cells(i, 2).Value
    s2.Cells(sat, 2).Value = s1.Cells(i, 3).Value
    For d = 9 To s1.Cells(i, Columns.Count).End(xlToLeft).Column
        sat = sat + 1
        s2.Cells(sat, 2).Value = s1.Cells(i, d).Value
        s2.Cells(sat, 3).Value = s1.Cells(i, 5).Value
    Next d
    sat = sat + 1
Next i
MsgBox "İşlem tamam"
End Sub

 

[veyselemre]

Sub test()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 3).End(3).Row

    Dim w(1 To 3, 1 To 1), z
    With CreateObject("Scripting.Dictionary")

        For i = 3 To son

            For Each m In s1.Range("I" & i & ":O" & i).SpecialCells(xlCellTypeConstants, 23)
                Key = Trim(m.Value)
                If .exists(Key) Then
                    z = .Item(Key)
                    idx = UBound(z, 2) + 1
                    ReDim Preserve z(1 To 3, 1 To idx)

                    z(1, idx) = Cells(i, 2)
                    z(2, idx) = Cells(i, 3)
                    z(3, idx) = Cells(i, 5)

                    .Item(Key) = z
                Else
                    w(1, 1) = Cells(i, 2)
                    w(2, 1) = Cells(i, 3)
                    w(3, 1) = Cells(i, 5)

                    .Item(Key) = w
                End If
            Next
        Next i

        kys = .keys

        s2.Select
        [a:c].ClearContents
        sat = 3
        For i = LBound(kys) To UBound(kys)
            Cells(sat, 2) = kys(i)
            sat = sat + 1
            v = .Item(kys(i))
            sira = Array("ALINDI", "ALINACAK", "ALINMAYACAK")

            For ii = 0 To 2
                For iii = 1 To UBound(v, 2)
                    If v(3, iii) = sira(ii) Then
                        Cells(sat, 1) = v(1, iii)
                        Cells(sat, 2) = v(2, iii)
                        Cells(sat, 3) = v(3, iii)
                        sat = sat + 1
                    End If
                Next iii
            Next ii
        Next i
    End With

End Sub

 

[Ömer BARAN]

Merhabalar Sayın veyselemre.

Size özel mesaj yazmak istedim ama sanırım sizin posta kutusu dolu olduğundan gönderemiyorum.

 

[veyselemre]

Alternatif ;

Sub test2()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 3).End(3).Row

    Dim w(1 To 4, 1 To 2)
    Set dic = CreateObject("Scripting.Dictionary")

    With CreateObject("Scripting.Dictionary")

        kod = 999
        For i = 3 To son
            If Cells(i, 5) = "ALINDI" Then
                drm = 1
            ElseIf Cells(i, 5) = "ALINACAK" Then
                drm = 2
            Else
                drm = 3
            End If

            For Each m In s1.Range("I" & i & ":O" & i).SpecialCells(xlCellTypeConstants, 23)
                key = Trim(m.Value)
                If Not .exists(key) Then
                    kod = kod + 1
                    veri = kod & "|" & "0" & "|" & "|" & key & "|"
                    dic(veri) = veri
                    .Item(key) = kod
                End If
                idx = .Item(key)
                veri = idx & "|" & drm & "|" & Cells(i, 2) & "|" & Cells(i, 3) & "|" & Cells(i, 5)
                dic(veri) = veri
            Next
        Next i

        s2.Select
        kys = dic.items

        For i = LBound(kys) To UBound(kys) - 1
            For ii = i + 1 To UBound(kys)
                If kys(i) > kys(ii) Then

                    tmp = kys(i)
                    kys(i) = kys(ii)
                    kys(ii) = tmp

                End If
            Next ii

        Next i

        [e:g].ClearContents

        For i = LBound(kys) To UBound(kys)
            bol = Split(kys(i), "|")
            Cells(i + 3, 5) = bol(2)
            Cells(i + 3, 6) = bol(3)
            Cells(i + 3, 7) = bol(4)
        Next i
    End With

End Sub

Aşağıdaki kod işlemlerin sıralama kısmını sayfa üzerinde yapıyor.

Sub test3()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 3).End(3).Row

    Dim w(1 To 4, 1 To 2)
    Set dic = CreateObject("Scripting.Dictionary")

    With CreateObject("Scripting.Dictionary")

        kod = 999
        For i = 3 To son
            If Cells(i, 5) = "ALINDI" Then
                drm = 1
            ElseIf Cells(i, 5) = "ALINACAK" Then
                drm = 2
            Else
                drm = 3
            End If

            For Each m In s1.Range("I" & i & ":O" & i).SpecialCells(xlCellTypeConstants, 23)
                key = Trim(m.Value)
                If Not .exists(key) Then
                    kod = kod + 1
                    veri = kod & "|" & "0" & "|" & "|" & key & "|"
                    dic(veri) = veri
                    .Item(key) = kod
                End If
                idx = .Item(key)
                veri = idx & "|" & drm & "|" & Cells(i, 2) & "|" & Cells(i, 3) & "|" & Cells(i, 5)
                dic(veri) = veri
            Next
        Next i

    End With

    s2.Select
    kys = dic.items
    [I:K].ClearContents

    [I3].Resize(UBound(kys) + 1, 1).Value = Application.Transpose(kys)
    
    With Range([I3], [I3].End(xlDown))
        .Sort Key1:=Range("I3"), Order1:=xlAscending, Header:=xlGuess
        Application.DisplayAlerts = False
        .TextToColumns Destination:=Range("I3"), Other:=True, OtherChar:="|"
        Application.DisplayAlerts = True
    End With
 [I:J].Delete Shift:=xlToLeft
End Sub