Makro Yardımıyla Özet Tablo Oluşturma.

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

PHP:
Sub rapor()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")

s2.Cells.ClearContents

son1 = s1.Cells(Rows.Count, "A").End(3).Row
s2.Activate

s1.Range("A2:A" & son1).Copy s2.[A5]

s2.Range("$A$5:$A$" & son1 + 4).RemoveDuplicates Columns:=1, Header:=xlNo
s2.Sort.SortFields.Clear
s2.Sort.SortFields.Add Key:=Range("A5"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
With s2.Sort
    .SetRange Range("A5:A" & son1 + 4)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
s2.Range("$A$5:$A$" & son1 + 4).Copy: s2.[B1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
s2.Range("A2:A" & Rows.Count).ClearContents

s1.Range("B2:B" & son1).Copy s2.[A2]

s2.Range("$A$2:$A$" & son1).RemoveDuplicates Columns:=1, Header:=xlNo
s2.Sort.SortFields.Clear
s2.Sort.SortFields.Add Key:=Range("A2"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
With s2.Sort
    .SetRange Range("A2:A" & son1)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Dim hucre As Range
sat = s2.Cells(Rows.Count, "A").End(3).Row
sut = s2.Cells(1, Columns.Count).End(xlToLeft).Column

For Each hucre In s2.Range(Cells(2, 2), Cells(sat, sut))
    hucre.FormulaR1C1 = "=SUMIFS(Sheet1!R2C3:R" & son1 & "C3,Sheet1!R2C2:R" & son1 & "C2,RC1,Sheet1!R2C1:R" & son1 & "C1,R1C)"
Next

s2.Range(Cells(1, 1), Cells(sat, sut)).Copy: s2.[A1].PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
s2.[A1].Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
s2.Range(Cells(1, 1), Cells(1, sut)).Font.Color = vbRed
s2.Range(Cells(1, 1), Cells(1, sut)).Font.Bold = True
s2.Range(Cells(1, 1), Cells(sat, 1)).Font.Bold = True
s2.Range(Cells(1, 1), Cells(sat, sut)).VerticalAlignment = xlCenter
s2.Range(Cells(1, 2), Cells(sat, sut)).HorizontalAlignment = xlCenter
s2.Range(Cells(1, 1), Cells(sat, 1)).HorizontalAlignment = xlLeft

End Sub
 
Üst