مساعدة فى كود ترحيل

[ayman.esam90]

التكرم بالمساعدة فى كود ترحيل مرفق بالملف بالشرح المطلوب وشكرا على تعاونكم 

Cashout Porg. Sales.rar

[سليم حاصبيا]

جرب هذا الماكرو  عدد 2 

تصحيح المعادلات بالعامود D

واحد للتوزيع على الصفحات

والثاني للتقرير بالمبيعات حسب التاريخ مع المجموع

Option Explicit
Sub Get_sales()
Dim i%, k%, x%
Dim s#
Dim arr, st$
Dim arr_Store_Name()
Dim Obj As Object
Set Obj = CreateObject("system.collections.arraylist")
Dim r%: r = Sheets("Cashout").Range("a1").CurrentRegion.Columns(1).Cells.Count
Sheets("المبيعات اليومية").Range("a2:c500").ClearContents
With Obj
For i = 2 To r
 If Not .contains(Sheets("Cashout").Range("a" & i).Value2) Then
  .Add Sheets("Cashout").Range("a" & i).Value2
End If
arr = .toarray
Next
End With
Sheets("المبيعات اليومية").Range("a2").Resize(UBound(arr) + 1) = Application.Transpose(arr)
 Obj.Clear
  With Sheets("المبيعات اليومية")
 k = Sheets("المبيعات اليومية").Range("a1").CurrentRegion.Columns(1).Cells.Count
  For i = 2 To k
   For x = 2 To r
    If .Cells(i, 1) = Sheets("Cashout").Cells(x, 1) Then
      st = Sheets("Cashout").Cells(x, 2)
     .Cells(i, 2) = .Cells(i, 2) & "," & st
     s = s + Sheets("Cashout").Cells(x, 3)
     End If
    Next
    .Cells(i, 2) = Right(.Cells(i, 2), Len(.Cells(i, 2)) - 1)
    .Cells(i, 3) = s
    st = "": s = 0
    Next
   End With
End Sub
Option Explicit
Rem=======================================
Sub SALIM()
Application.ScreenUpdating = False
Dim i%, k
Dim Main_sh As Worksheet
Dim My_table As Range
Dim mY_sh As Worksheet
Set Main_sh = Sheets("Cashout")
Set My_table = Main_sh.Range("a1").CurrentRegion
 
For i = 1 To Sheets.Count

On Error Resume Next
k = CInt(Sheets(i).Name)
If Not IsEmpty(k) Then
 Set mY_sh = Sheets(i)
 With mY_sh
  .Cells.Clear
  .Range("z1") = "Store Name"
  .Range("z2") = k
  My_table.AdvancedFilter Action:=2, CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=.Range("A1")
 .Range("Z1:Z2").Clear
 End With
k = Empty
End If
Next
Application.ScreenUpdating = True
End Sub

الملف مرفق

Salim By symbols2.xls