• Merhaba, 22 Ocak 2020 Çarşamba günü sabah 08:00 ile 12:00 saatleri arasında forumun bulunduğu sunucuda genel bakım çalışması yapılacaktır.
    Bu sürenin tamamında olmasa da bir süreliğine forum geçici olarak erişilemez olacaktır. Bilgilerinize

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

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
8,089
Excel Vers. ve Dili
İş : Ofis 2016 - Türkçe
Ev: Ofis 2016 - 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