- Katılım
- 4 Eylül 2020
- Mesajlar
- 394
- Excel Vers. ve Dili
- Excel 2016
- Altın Üyelik Bitiş Tarihi
- 22-11-2022
Merhaba aşagıdaki kodu ekteki dosyaya göre uyarlabilirmiyiz. Teşekkür ederim
Kod:
Option Explicit
Sub Analiz()
Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Urun_Grubu As Variant
Dim Veri As Variant, Son As Long, Satir As Long, Kayit_Sayisi As Long, Say As Long
Dim Alan_1 As Range, Alan_2 As Range, X As Long, Y As Long, Z As Byte, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("KIRPILMIS")
Set S2 = Sheets("GRUP")
Set Dizi = CreateObject("Scripting.Dictionary")
S2.Cells.Delete
Satir = 3
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
If Son = 2 Then Son = 3
S1.Cells(1, 27) = "Sıra No"
With S1.Range("AA2")
.Value = 1
.AutoFill Destination:=S1.Range("AA2:AA" & Son), Type:=xlFillSeries
End With
S1.Range("A2:AA" & Son).Sort S1.Range("K2"), xlAscending, S1.Range("B2"), , xlAscending
Veri = S1.Range("A1:K" & Son).Value
S1.Range("A2:AA" & Son).Sort S1.Range("AA2"), xlAscending
S1.Range("AA:AA").Clear
With Dizi
For X = LBound(Veri) + 1 To UBound(Veri)
If Veri(X, 11) <> "" Then .Item(Veri(X, 11)) = 1
Next
End With
Urun_Grubu = Dizi.Keys
Kayit_Sayisi = Son + Dizi.Count * 2 * 2 - 2
ReDim Liste(1 To Kayit_Sayisi, 1 To 11)
Say = 1
For X = LBound(Urun_Grubu) To UBound(Urun_Grubu)
If Say = 1 Then Liste(Say, 11) = Now
Liste(Say + 1, 1) = Urun_Grubu(X)
If Alan_1 Is Nothing Then
Set Alan_1 = S2.Cells(Say + 1, 1).Resize(, 11)
Set Alan_2 = S2.Cells(Say + 2, 1).Resize(, 11)
Else
Set Alan_1 = Union(Alan_1, S2.Cells(Say + 1, 1).Resize(, 11))
Set Alan_2 = Union(Alan_2, S2.Cells(Say + 2, 1).Resize(, 11))
End If
Say = Say + 2
For Y = LBound(Veri) To UBound(Veri)
If Y = 1 Then
For Z = 1 To 11
Liste(Say, Z) = Veri(Y, Z)
Next
Else
If Veri(Y, 11) = Urun_Grubu(X) Then
Say = Say + 1
For Z = 1 To 11
If Z = 1 Then
Liste(Say, Z) = CStr(Veri(Y, Z))
Else
Liste(Say, Z) = Veri(Y, Z)
End If
Next
End If
End If
Next
Say = Say + 2
Next
S2.Range("A:A").NumberFormat = "@"
S2.Range("A1").Resize(Say - 2, 11) = Liste
If Not Alan_1 Is Nothing And Not Alan_2 Is Nothing Then
With Alan_1
.MergeCells = True
.Font.Bold = True
.Interior.Color = 14277081
.HorizontalAlignment = xlCenter
End With
With Alan_2
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
End If
S2.Range("A:K").ColumnWidth = 255
S2.Rows.AutoFit
S2.Columns.AutoFit
Set S1 = Nothing
Set S2 = 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
