ترحيل بيانات من صفحة رئيسية الى عدة صفحات

[الشيباني1]

السلام عليكم ..اخواني الاعزاء ما وددت ندخل خبراءنا الاعزاء في هذا الموضوع هو لغرض تسجيل كود لترحيل جدول ( البيع ) الى الاوراق المثبته في البرنامج مع جزيل شكري وتقديري

انتبه من فضلك فطالما تريد الحل بالأكواد فكان عليك لزاماً رفع الملف بإمتداد يقبل إضافة الأكواد XLSM ..تــــم اعادة رفع الملف تجنباً لإهدار وقت الأساتذة

sample.xlsm

[محمد هشام.]

تفضل اخي الكريم

Sub ترحيل()
    Application.ScreenUpdating = False
    For L = 10 To Range("X65500").End(xlUp).Row
        MH = Cells(L, "X")
        If FeuilleExiste(MH) = False And MH <> "" Then
            MsgBox "المرجوا التحقق من وجود اوراق الوكلاء "
            Exit Sub
        End If
       ' افراغ
        Sheets(MH).Range("B10:P1000").ClearContents
    Next L
  
    For L = 10 To Range("X65500").End(xlUp).Row
        MH = Cells(L, "X")
        With Sheets(MH)
            DL = .Range("B65500").End(xlUp).Row
            If DL = 8 Then DL = 9  'نبدا من الصف 10
            DL = DL + 1
            .Cells(DL, "B") = Cells(L, "N")      'التاريخ
            .Cells(DL, "D") = Cells(L, "P") 'الوزن (طن )
            .Cells(DL, "F") = Cells(L, "R")       'السعر
            .Cells(DL, "H") = Cells(L, "T")       'المبلغ
            .Cells(DL, "J") = Cells(L, "V")      'المجهز
            .Cells(DL, "L") = Cells(L, "Z")   'اجور النقل
            .Cells(DL, "N") = Cells(L, "AB")     'السماح
            .Cells(DL, "P") = Cells(L, "AD")      'الفرق
        End With
    Next L
End Sub
Function FeuilleExiste(FeuilleAVerifier)
Dim Feuille As Worksheet
    FeuilleExiste = False
    For Each Feuille In Worksheets
        If UCase(Feuille.Name) = UCase(FeuilleAVerifier) Then
            FeuilleExiste = True
            Exit Function
        End If
    Next Feuille
Exit Function
SiErreur:
MsgBox "Une erreur s'est MHe..."
FeuilleExiste = CVErr(xlErrNA)
End Function

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

 

  Sub انشاء_ورقةجديدة_MH()
  Dim Ind As Integer
  Dim FlgExist As Boolean, Test As String
  Application.ScreenUpdating = False
 Feuil2.Copy After:=Sheets(Sheets.Count)
  Ind = 1
  Do
    On Error Resume Next
    Test = Sheets("وكيل" & Ind).Range("A1").Value
    If Err.Number = 0 Then FlgExist = True: Ind = Ind + 1 Else FlgExist = False
  Loop While FlgExist
  On Error GoTo 0
  ActiveSheet.Name = "وكيل" & Ind
 Range("B10:P1000").ClearContents
 Dim rng As Range
    For Each rng In ActiveSheet.UsedRange
   If rng.HasFormula Then
   rng.Formula = rng.Value
        End If
    Next rng
 Feuil1.Select
  Application.ScreenUpdating = True
End Sub

sample_MH.xlsm

[الشيباني1]

استاذنا العزيز احييكم وحل اكثر من رائع بوركتم وجزاكم الرحمن خير الجزاء

[محمد هشام.]

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

Sub Copy()
     Application.ScreenUpdating = False
    Dim i As Long, v As Variant, srcWS As Worksheet, cnt As Long, lRow As Long
    Set srcWS = Sheets("رئيسيه")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = srcWS.Range("X10", srcWS.Range("X" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(v(i, 1)).Range("B10:P1000").ClearContents
                With srcWS
               
                    .Range("N8:AD" & lRow).AutoFilter Field:=11, Criteria1:=v(i, 1)
                    cnt = .[subtotal(103,N:N)] - 1
                    .Range("N10:V" & lRow).SpecialCells(xlCellTypeVisible).Copy Sheets(v(i, 1)).Range("B10")
                    .Range("Z10:AB" & lRow).SpecialCells(xlCellTypeVisible).Copy Sheets(v(i, 1)).Range("L10")
                    Sheets(v(i, 1)).Range("P10:P" & 9 + cnt).Formula = "=IFERROR(IF(RC[-14]="""","""",RC[-8]-RC[-4]-RC[-2]),"""")"
                       
                End With
            End If
        Next i
    End With
    srcWS.Range("N8").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[محمد هشام.]

تفضل اخي

2_MH.xlsm

[الشيباني1]

اخي العزيز مع شكري وتقديري ما الخلل في الكود المسبب لما يظهر في ورقتي الوكلاء ( 3 و 5 ) مع الشكر

3_MH.xlsm

[محمد هشام.]

ربما قد قمت بتغيير تنسيقات احدى الخلايا في جدول البيع .!!!!!! يمكنك الرجوع للملف الدي سبق وان رفعته لك ليس به اي مشكلة عند الترحيل على العموم قد تم اصلاح الملف

وتفاديا لحصول نفس المشكلة معك في مرة مقبلة يمكنك تطويع الكود الاول ليؤدي نفس المهمة باضافة هدا السطر حيث يتم  اضافة  المعادلة في عمود الفرق اثناء الترحيل

.Cells(DL, "P").Formula = "=IFERROR(IF(RC[-14]="""","""",RC[-8]-RC[-4]-RC[-2]),"""")"

4_MH.xlsm

[الشيباني1]

اشكرك جدا وادامك الرحمن لنا منقذا