Option Explicit
Sub abodahab_send_data()
Dim myArray As Variant
Dim Arr As Variant
Dim lr As Long
Dim rw As Long
Dim x As Long
Dim r As Long
Dim dmin As Date
Dim dmax As Date
Dim target As Date
Dim data As Worksheet
Dim send As Worksheet
'____________________________________________
Set data = Worksheets("data") 'اسم شيت قاعدة البيانات
Set send = Worksheets("Moda Show")
'____________________________________________
lr = data.Cells(Rows.Count, 7).End(xlUp).Row 'اخر صف به بيانات
myArray = data.Range("a2:l" & lr) 'نطاق البحث
ReDim y(1 To lr + 3, 1 To 5) ' انشاء مصفوفة جديده لحفظ البيانات بها
'____________________________________________
dmin = Application.WorksheetFunction.Min(data.Range("g2:g" & lr).Value2)
dmax = Application.WorksheetFunction.Max(data.Range("g2:g" & lr).Value2)
target = dmin
'____________________________________________
Arr = UniqueListFromRange(data.Range("L1:L" & lr))
rw = 1
'____________________________________________
Do While target <= dmax
For r = 1 To UBound(Arr)
If y(rw, 1) <> "" Then rw = rw + 1
For x = 1 To lr - 1
If myArray(x, 12) = Arr(r) And myArray(x, 7) = target Then
y(rw, 1) = target
y(rw, 2) = "comp"
y(rw, 3) = myArray(x, 12)
y(rw, 4) = myArray(x, 8) & "+" & y(rw, 4)
y(rw, 5) = myArray(x, 1) + y(rw, 5)
End If
Next x
Next r
If y(rw, 1) <> "" Then rw = rw + 1
target = target + 1
Loop
If rw > 0 Then
For x = 1 To rw
If Right(y(x, 4), 1) = "+" Then y(x, 4) = Left(y(x, 4), Len(y(x, 4)) - 1)
Next x
send.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 5).Value = y()
MsgBox "تم الترحيل بنجاح"
End If
End Sub
Public Function UniqueListFromRange(rgInput As Range) As Variant
Dim d As Object
Dim dataSet As Variant
Dim rgArea As Range
Dim x As Long
Dim y As Long
Set d = CreateObject("Scripting.Dictionary")
For Each rgArea In rgInput.Areas
dataSet = rgArea.Value
If IsArray(dataSet) Then
For x = 1 To UBound(dataSet)
For y = 1 To UBound(dataSet, 2)
If Len(dataSet(x, y)) <> 0 Then d(dataSet(x, y)) = Empty
Next y
Next x
Else
d(dataSet) = Empty
End If
Next rgArea
UniqueListFromRange = d.Keys
End Function
وبجد كان كود مرهق ولا تنتظر ان احد بالمستقبل يعمل لك كل ده ابداء بالعمل , ولو وقف معاك حاجه بلغنا نساعدك
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
