السلام عليكم
يتم استخراج البيانات لكل القيم الفريدة في العمود بي للورقة Data1
Option Explicit
Private Const ContColmn As Integer = 5
'======================================================
'======================================================
Sub kh_Report()
Dim obj As Object
Dim Ar() As Double, XX() As Double, X() As Double
Dim v As Double, vv As Double
Dim Rng As Range
Dim LastRow As Long, iCont As Long
Dim i As Long, ii As Long, iii As Long, R As Long
Dim C As Integer
Dim tx
''''''''''''''''''''''
On Error GoTo kh_ex
Set obj = CreateObject("Scripting.Dictionary")
'''''''''''''''''''''
'============================================
kh_Clear
'============================================
With æÑÞÉ2
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:D" & LastRow)
End With
'============================================
ReDim Ar(1 To ContColmn - 1)
For C = 1 To ContColmn - 1
Ar(C) = Range("B1").Cells(1, C).Value
Next
tx = Range("F1").Value
'============================================
kh_Application False
With Rng
.Sort .Columns(2), xlAscending
For i = 1 To .Rows.Count
v = .Cells(i, "B").Value
vv = Val(.Cells(i, "D"))
If obj.Exists(v) Then
iii = obj(v)
''''''''''''''''''
If .Cells(i, "C").Value = tx Then
For C = 1 To ContColmn - 1
If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = XX(C + 1, iii) + vv
Next
End If
Else
ii = ii + 1
ReDim Preserve XX(1 To ContColmn, 1 To ii)
obj.Add v, ii
''''''''''''''''''
XX(1, ii) = v
If .Cells(i, "C").Value = tx Then
For C = 1 To ContColmn - 1
If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = vv
Next
End If
End If
Next
End With
'''''''''''''''''''''''''''''''
iCont = obj.Count
If iCont Then
Erase Ar
ReDim Ar(1 To ContColmn - 1)
ReDim X(1 To iCont, 1 To ContColmn)
For i = 1 To iCont
X(i, 1) = XX(1, i)
For C = 1 To ContColmn - 1
Ar(C) = Ar(C) + XX(C + 1, i)
X(i, C + 1) = Ar(C)
Next
Next
With Range("A2").Resize(iCont, ContColmn)
If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats
.Value = X
End With
'''''''''''''''''''''''''
End If
'============================================
kh_ex:
kh_Application True
''''''''''''''''''
''''''''''''''''''
''''''''''''''''''
Set obj = Nothing
Set Rng = Nothing
Erase XX, X, Ar
''''''''''''''''''
If Err Then
MsgBox "Err.Number : " & Err.Number
Err.Clear
End If
End Sub
شاهد المرفق 2010
Ex1.rar