DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Düğme1_Tıklat()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 2
'Sheet with data in it
Set ws = Sheets("ÇALIŞMA detay")
Sheets("ÇALIŞMA detay").Select
Columns("l:l").Select
Selection.Delete Shift:=xlToLeft
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:k1"
TitleRow = Range(vTitles).Cells(1).Row
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from vCol
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"
For Itm = 2 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
' alfabetik sıralama için aşağıdaki ws'den önceki ' işaretinin silmek yeterli:
'ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
'clear temporary list
ws.Columns(iCol).Clear
'Turn on the autofilter
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!B1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
Else 'clear sheet if it exists
Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
Sheets(MyArr(Itm) & "").Cells.Clear
End If
ws.Range("B" & TitleRow & ":B" & LR).EntireRow.Copy _
Sheets(MyArr(Itm) & "").Range("A1")
Sheets(MyArr(Itm) & "").Range("B1").Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(7, 8, 9, 10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ws.Range(vTitles).AutoFilter Field:=vCol
MyCount = MyCount + Sheets(MyArr(Itm) & "").Range("B" & Rows.Count) _
.End(xlUp).Row - Range(vTitles).Rows.Count
Sheets(MyArr(Itm) & "").Columns.AutoFit
Sheets(MyArr(Itm) & "").Columns("B:B").ColumnWidth = 40
sonsatir = Range("h1").End(xlDown).Row
Range(Cells(1, 1), Cells(sonsatir, 2)).Select
Selection.Sort _
Key1:=Worksheets("Sheet1").Columns("A"), _
Header:=xlGuess
If WorksheetFunction.Count(Sheets(MyArr(Itm) & "").Range("K2:K" & Rows.Count)) > 1 Then
fat = Sheets(MyArr(Itm) & "").Cells(Rows.Count, "K").End(3).Row
Sheets(MyArr(Itm) & "").Range("K3:K" & fat).Clear.contents
Sheets(MyArr(Itm) & "").Range("K2:K" & fat).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.Name = "Calibri"
.Size = 48
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.Color = -16777216
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = -90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
End With
End If
Columns("K:K").ColumnWidth = 9
Next Itm
Sheets("ORJ").Select
Range("u1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("ÇALIŞMA detay").Select
Range("l1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("ÇALIŞMA detay").Select
Range("a1").Select
Unload UserForm2
Application.ScreenUpdating = True
End Sub