ترحيل البيانات حسب اسم المخزن

[sabah2023]

السلام عليكم ، حصلت على كود من المنتدى ، ترحيل البيانات

ممكن معالجة كود ترحيل البيانات حسب اسم المخزن 

مع اضافة كود مسح الشيتات المرحلة لانه تضاف بين فترة وفترة بيانات جديدة ومخازن جديدة

جزيتم خيرا

ترحيل البيانات حسب اسم المخزن مع مسح البيانات المرحلة في حالة وجود بيانات جديدة.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

لم استوعب الطلب جيدا لاكن على العموم تفضل جرب ووافينا بالنتيجة

 

Sub Unique_Stores()
 
    Dim rng         As Range, cRng As Range
    Dim cell        As Range, Lastrow As Long
    Dim wsDest      As Variant, s As String
    Dim cUnique     As Collection
    

    Set WSData = ThisWorkbook.Sheets("aaa")
    'عمود الفلترة
    Set rng = WSData.Range("L2:L" & WSData.Cells(WSData.Rows.Count, "L").End(xlUp).Row)
    Set cUnique = New Collection
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.CopyObjectsWithCells = False
    
    ' حدف الاوراق السابقة
    For Each ws In Sheets
       If ws.Name <> WSData.Name Then ws.Delete
    Next
    On Error Resume Next
    For Each cell In rng.Cells
        cUnique.Add cell.Value, CStr(cell.Value)
        
    Next cell
    On Error GoTo 0
    ' انشاء اوراق جديدة
    For Each wsDest In cUnique
        s = wsDest
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest
        ActiveSheet.DisplayRightToLeft = True

With WSData

    Lastrow = .Cells(.Rows.Count, "L").End(xlUp).Row
     .Range("A2").AutoFilter field:=12, Criteria1:=wsDest
 ' النطاق المنسوخ
Set cRng = .Range("A1:S" & Lastrow)
 cRng.Copy Sheets(s).Range("A2")
.Select
.[A2].AutoFilter
    
        End With
        
    Next wsDest
    
'''''''''تنسيق الاوراق الجديدة '''''''

For Each wsCopy In ThisWorkbook.Worksheets
If wsCopy.Name <> WSData.Name Then
'خلية اسم المخزن
Set rng = wsCopy.[G1]
 rng = "المخزن" & "" & wsCopy.Name
 
With rng
 .Font.Name = "Algerian": .Font.Size = 20: .Font.Color = vbBlue
End With

' تنسيق الاعمدة
For i = 1 To 19
wsCopy.Columns(i).ColumnWidth = WSData.Columns(i).ColumnWidth
wsCopy.Rows(i).RowHeight = WSData.Rows(i).RowHeight

' التحقق من خطأ تنسيق الخلايا
Application.ErrorCheckingOptions.BackgroundChecking = False

Next
'**************************************************
' لتسمية الاوراق باسم المخزن قم بتفعيل السطر التالي

' wsCopy.Name = rng

'*************************************************
    End If
         
Next wsCopy
   
WSData.Activate

Application.ScreenUpdating = True
Application.CopyObjectsWithCells = True
End Sub

 

ترحيل البيانات حسب اسم المخزن.xlsb

[sabah2023]

السلام عليكم - جزاك الله خيراً 

هو هذا المطلوب