"Gant" Sayfasındaki Mükerrer verileri "Detay" sayfası "A" sütununda Toplama
Aşağıdaki kod Dosyada yaptığımız bazı değişikliklerden dolayı çalışmıyor.Şöyle ki, Gant Sayfasında Tarihlerin altında bulunan Mükerrer verilerin "Detay" Sayfasında A Sütununun altında toplanmasına çalışıyorum. Hatta mümkünse yine detay sayfasında, 1. Satırdaki tarihlerin altında ilgili veriden kaç tane olduğunu yazdırmak istiyorum.
Elimde daha önce kullandığım, şu anda belirleyemediğim bir sorundan çalıştıramadığım bir kod dizini var.
Yardımcı olacak herkese teşekkür ediyorum.
Sub Arama()
Dim SİPARİŞ As New Collection, VERİ As Range
Dim X As Long, Y As Byte, SATIR As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Detay").Select
Range("A3:C65536").ClearContents
With Sheets("Gant")
On Error Resume Next
For X = 4 To .Range("A65536").End(3).Row
For Y = 2 To .Range("IV3").End(1).Column
SİPARİŞ.Add .Cells(X, Y), CStr(.Cells(X, Y))
Next
Next
End With
SATIR = 2
For Each VERİ In SİPARİŞ
If WorksheetFunction.CountIf(Sheets("Silinecek_Veriler").Range("A:A"), VERİ) = 0 Then
Cells(SATIR, 1) = VERİ
Cells(SATIR, 2).FormulaArray = "=IF(RC1="""","""",INDIRECT(""Gant!""&ADDRESS(2,MIN(IF(Gant!R3C5:R156C259=RC1,COLUMN(Gant!C5:C259))))))"
Cells(SATIR, 3).FormulaArray = "=IF(RC1="""","""",INDIRECT(""Gant!""&ADDRESS(2,MAX(IF(Gant!R3C5:R156C259=RC1,COLUMN(Gant!C5:C259))))))"
SATIR = SATIR + 1
End If
Next
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Aşağıdaki kod Dosyada yaptığımız bazı değişikliklerden dolayı çalışmıyor.Şöyle ki, Gant Sayfasında Tarihlerin altında bulunan Mükerrer verilerin "Detay" Sayfasında A Sütununun altında toplanmasına çalışıyorum. Hatta mümkünse yine detay sayfasında, 1. Satırdaki tarihlerin altında ilgili veriden kaç tane olduğunu yazdırmak istiyorum.
Elimde daha önce kullandığım, şu anda belirleyemediğim bir sorundan çalıştıramadığım bir kod dizini var.
Yardımcı olacak herkese teşekkür ediyorum.
Sub Arama()
Dim SİPARİŞ As New Collection, VERİ As Range
Dim X As Long, Y As Byte, SATIR As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Detay").Select
Range("A3:C65536").ClearContents
With Sheets("Gant")
On Error Resume Next
For X = 4 To .Range("A65536").End(3).Row
For Y = 2 To .Range("IV3").End(1).Column
SİPARİŞ.Add .Cells(X, Y), CStr(.Cells(X, Y))
Next
Next
End With
SATIR = 2
For Each VERİ In SİPARİŞ
If WorksheetFunction.CountIf(Sheets("Silinecek_Veriler").Range("A:A"), VERİ) = 0 Then
Cells(SATIR, 1) = VERİ
Cells(SATIR, 2).FormulaArray = "=IF(RC1="""","""",INDIRECT(""Gant!""&ADDRESS(2,MIN(IF(Gant!R3C5:R156C259=RC1,COLUMN(Gant!C5:C259))))))"
Cells(SATIR, 3).FormulaArray = "=IF(RC1="""","""",INDIRECT(""Gant!""&ADDRESS(2,MAX(IF(Gant!R3C5:R156C259=RC1,COLUMN(Gant!C5:C259))))))"
SATIR = SATIR + 1
End If
Next
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Son düzenleme:
