DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Analiz()
Dim S1 As Worksheet, S2 As Worksheet, Dizi_A As Object, Dizi_B As Object
Dim Veri As Variant, X As Long, Aranan As String, Say As Long, Son As Long
Dim WF As WorksheetFunction, Dizi_Item, Y As Integer, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("DATA")
Set S2 = Sheets("ÖZET")
Set WF = WorksheetFunction
Set Dizi_A = CreateObject("Scripting.Dictionary")
Set Dizi_B = CreateObject("Scripting.Dictionary")
S2.Cells.Clear
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
If Son = 2 Then Son = 3
S1.Range("I2") = 1
S1.Range("I2").AutoFill Destination:=S1.Range("I2:I" & Son), Type:=xlFillSeries
S1.Range("A2:I" & Son).Sort S1.Range("H2"), xlAscending
Veri = S1.Range("A2:H" & Son).Value
S1.Range("A2:I" & Son).Sort S1.Range("I2"), xlAscending
S1.Range("I:I").ClearContents
For X = LBound(Veri) To UBound(Veri)
Aranan = Veri(X, 2) & "|" & Veri(X, 8)
If Not Dizi_A.Exists(Aranan) Then
Dizi_A.Add Aranan, 1
Else
Dizi_A.Item(Aranan) = Dizi_A.Item(Aranan) + 1
End If
Next
For X = LBound(Veri) To UBound(Veri)
Aranan = Veri(X, 2) & "|" & Veri(X, 8)
If Not Dizi_B.Exists(Split(Aranan, "|")(1)) Then
Dizi_B.Add Split(Aranan, "|")(1), Dizi_A.Item(Aranan)
Else
Dizi_B.Item(Split(Aranan, "|")(1)) = WF.Max(Dizi_B.Item(Split(Aranan, "|")(1)), Dizi_A.Item(Aranan))
End If
Next
ReDim Sutun_Basliklari(1 To 1)
For Each Dizi_Item In Dizi_B.Keys
For X = 1 To Dizi_B.Item(Dizi_Item)
Say = Say + 1
ReDim Preserve Sutun_Basliklari(1 To Say)
Sutun_Basliklari(Say) = Dizi_Item
Next
Next
ReDim Liste(1 To Son, 1 To Say + 2)
Dizi_A.RemoveAll
Say = 0
For X = LBound(Veri) To UBound(Veri)
Aranan = Veri(X, 4) & "|" & Veri(X, 8)
If Not Dizi_A.Exists(Veri(X, 2)) Then
Say = Say + 1
Dizi_A.Add Veri(X, 2), Say
Liste(Say, 1) = Veri(X, 2)
Liste(Say, 2) = Veri(X, 3)
For Y = LBound(Sutun_Basliklari) To UBound(Sutun_Basliklari)
If Sutun_Basliklari(Y) = Veri(X, 8) Then
If Liste(Say, Y + 2) = "" Then
Liste(Say, Y + 2) = Veri(X, 4)
Exit For
End If
End If
Next
Else
For Y = LBound(Sutun_Basliklari) To UBound(Sutun_Basliklari)
If Sutun_Basliklari(Y) = Veri(X, 8) Then
If Liste(Dizi_A.Item(Veri(X, 2)), Y + 2) = "" Then
Liste(Dizi_A.Item(Veri(X, 2)), Y + 2) = Veri(X, 4)
Exit For
End If
End If
Next
End If
Next
If Say > 0 Then
S2.Range("A1:B1") = Array("Malzeme Kodu", "Malzeme Adı")
S2.Range("C1").Resize(1, UBound(Sutun_Basliklari)) = Sutun_Basliklari
S2.Range("A1").Resize(1, UBound(Sutun_Basliklari) + 2).Font.Bold = True
S2.Range("A1").Resize(1, UBound(Sutun_Basliklari) + 2).HorizontalAlignment = xlCenter
S2.Range("A2").Resize(Say, UBound(Liste, 2)) = Liste
S2.Columns.AutoFit
S2.Select
End If
Set S1 = Nothing
Set S2 = Nothing
Set WF = Nothing
Set Dizi_A = Nothing
Set Dizi_B = Nothing
Application.ScreenUpdating = True
MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Option Explicit
Sub ozetle()
Dim S1 As Worksheet, S2 As Worksheet
Dim Veri, bul, itms, kys, ver
Dim Son As Long, i As Long, ii As Long
Dim al As String, mx As Integer, uz As Integer, Say As Integer
Set S2 = Sheets("ozet")
Application.ScreenUpdating = False
Sheets("Data").Copy Sheets("Data")
Set S1 = ActiveSheet
Range("A:A,E:G").Delete
[a1].CurrentRegion.Sort [d1], , [a1], , , , , xlYes
Set S1 = ActiveSheet
Son = Cells(Rows.Count, 1).End(3).Row
Veri = Range("A2:D" & Son).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Veri)
al = Veri(i, 4) & "|" & Veri(i, 1)
.Item(al) = .Item(al) + 1
Next i
itms = .items
kys = .Keys
.RemoveAll
For i = LBound(itms) To UBound(itms)
al = Split(kys(i), "|")(0)
If .Exists(al) Then
mx = .Item(al)
If mx < itms(i) Then .Item(al) = itms(i)
Else
.Item(al) = itms(i)
End If
Next i
itms = .items
kys = .Keys
uz = WorksheetFunction.Sum(itms)
Dim baslik
ReDim baslik(1 To 1, 1 To uz)
For i = LBound(itms) To UBound(itms)
For ii = 1 To itms(i)
Say = Say + 1
baslik(1, Say) = kys(i)
Next ii
Next i
S2.Select
Cells.ClearContents
Range("C1").Resize(1, uz).Value = baslik
S1.Select
[a1].CurrentRegion.Sort [a1], , [d1], , , , , xlYes
Veri = Range("A2:D" & Son).Value
.RemoveAll
For i = 1 To UBound(Veri)
.Item(Veri(i, 1)) = Veri(i, 2)
Next i
S2.Select
itms = .items
kys = .Keys
For i = LBound(itms) To UBound(itms)
Cells(i + 2, 1) = kys(i)
Cells(i + 2, 2) = itms(i)
Next i
.RemoveAll
For i = 2 To Cells(Rows.Count, 1).End(3).Row
For ii = 3 To Cells(1, Columns.Count).End(1).Column
al = Cells(i, 1) & "|" & Cells(1, ii)
If .Exists(al) Then
ver = .Item(al)
ver = ver & "," & Cells(i, ii).Address
.Item(al) = ver
Else
ver = "," & Cells(i, ii).Address
.Item(al) = ver
End If
Next ii
Next i
For i = 1 To UBound(Veri)
al = Veri(i, 1) & "|" & Veri(i, 4)
bul = Split(.Item(al), ",")
For ii = LBound(bul) To UBound(bul)
If bul(ii) <> "" Then
Range(bul(ii)) = Veri(i, 3)
bul(ii) = ""
.Item(al) = Join(bul, ",")
Exit For
End If
Next ii
Next i
End With
S2.Range("A1:B1") = Array("Malzeme Kodu", "Malzeme Adı")
S2.Range("A1").Resize(1, uz + 2).Font.Bold = True
S2.Range("A1").Resize(1, uz + 2).HorizontalAlignment = xlCenter
S2.Columns.AutoFit
Application.DisplayAlerts = False
S1.Delete
Application.DisplayAlerts = True
End Sub