DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Listele()
Dim S1 As Worksheet, Veri As Variant, Dizi As Object, X As Long
Dim Son As Long, Sutun As Integer, Say As Long, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("Sayfa1")
Set Dizi = CreateObject("Scripting.Dictionary")
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
Veri = S1.Range("A2:C" & Son).Value2
S1.Range("D:" & Replace(Cells(1, Columns.Count).Address(0, 0), 1, "")).Clear
ReDim Liste(1 To UBound(Veri), 1 To 3)
For X = LBound(Veri) To UBound(Veri)
If Not Dizi.Exists(Veri(X, 2)) Then
Say = Say + 1
Dizi.Add Veri(X, 2), Say
Liste(Say, 1) = Veri(X, 3)
Liste(Say, 2) = Veri(X, 2)
Liste(Say, 3) = Veri(X, 1)
Else
Liste(Dizi.Item(Veri(X, 2)), 3) = Liste(Dizi.Item(Veri(X, 2)), 3) & "|" & Veri(X, 1)
End If
Next
If Say > 0 Then
S1.Range("D2").Resize(Say, 3) = Liste
S1.Range("F2").Resize(Say).TextToColumns Tab:=True, OtherChar:="|"
Sutun = S1.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
With S1.Range("D1:E1")
.Value = Array("Sıra No", "Stok Kodu")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
With S1.Range("F1")
.Value = "Fiyat 1"
.Font.Bold = True
.HorizontalAlignment = xlCenter
.AutoFill Destination:=S1.Range("F1:" & Cells(1, Sutun).Address(0, 0)), Type:=xlFillDefault
End With
End If
Set S1 = Nothing
Set Dizi = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
=İNDİS($B:$B;SATIR()*4-6)
=İNDİS($A:$A;SATIR()*4-6+MOD(SÜTUN();6))
=EĞERHATA(İNDİS($B$2:$B$1000;KAÇINCI(0;EĞER($B$2:$B$1000<>"";EĞERSAY($E$1:E1;$B$2:$B$1000));0));"")
=EĞER($E2="";"";EĞERHATA(İNDİS($A$2:$A$1000;KÜÇÜK(EĞER($B$2:$B$1000=$E2;SATIR($B$2:$B$1000)-1);SÜTUNSAY($F$1:F$1)));""))