Mevcut bir tablodan yeni bir tablo oluşturma

Katılım
10 Kasım 2009
Mesajlar
2
Excel Vers. ve Dili
2007
Merhabalar,
Ekli dosyadaki gibi bir tablom var. Verilerin girili olduğu soldaki tablodan sağda başlıklar halinde verdiğim formatta bir tablo oluşturmaya çalışıyorum. Elde binlerce veri olduğu için bu işi nasıl yapabilirim ?
ps: excel konusunda çok ama çok yeniyim.
 

Ekli dosyalar

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Bir bakın bakalım böylemi olacak.:cool:
Kod:
Sub tablo_aktar()
Dim i As Long, sat As Long, k As Range
Sheets("insaat").Select
Application.ScreenUpdating = False
Range("F2:O65536").ClearContents
For i = 2 To Cells(65536, "A").End(xlUp).Row
    Set k = Range("F2:F65536").Find(Cells(i, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        sat = k.Row
        Else
        sat = Cells(65536, "F").End(xlUp).Row + 1
        Cells(sat, "F").Value = Cells(i, "A").Value
        Cells(sat, "G").Value = Cells(i, "B").Value
    End If
    Set k = Range("H1:IV1").Find(Cells(i, "C").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(sat, k.Column).Value = Cells(sat, k.Column).Value + Cells(i, "D").Value
    End If
    Cells(sat, "O").Value = WorksheetFunction.Sum(Range("H" & sat & ":N" & sat))
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamdır." & vbLf & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 

Ekli dosyalar

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Alternatif olsun.

Kod:
Sub Deneme()
Application.ScreenUpdating = False
Dim c As Integer, b As Long
Range("F2:O65536").ClearContents
son = [A65536].End(3).Row
Range("A1:B" & son).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1:G1"), Unique:=True
For b = 2 To [F65536].End(3).Row
For c = 8 To 14
Cells(b, c) = Evaluate("=SumProduct((insaat!A2:A" & son & "=" & Cells(b, 6).Address & ")*(insaat!B2:B" & son & "=" & Cells(b, 7).Address & ")*(insaat!C2:C" & son & "=" & Cells(1, c).Address & ")*(insaat!D2: D" & son & "))")
Cells(b, 15) = "=SUM(RC[-7]:RC[-1])"
Next c, b
Application.ScreenUpdating = True
End Sub
.
 

Ekli dosyalar

Katılım
10 Kasım 2009
Mesajlar
2
Excel Vers. ve Dili
2007
Merhabalar,

Cok tesekkur ederim. Bilgiyi paylasmayi seven insanlarin varligi cok guzel!
 
Üst