ترحيل بيانات من ورقة data الى اوراق متعددة

[مصطفى محمود مصطفى]

السلام عليكم
هل يمكن ترحيل البيانات من ورقة data الى ورقة أخرى تأخذ رقم 1 وهكذا كلما تصل التعبئة للبيانات الى الصف38 تترحل الى ورقة جديدة مع الإجمالي تحمل رقم مسلسل من 1 الى أي رقم ينتهي به المصنف مع ملاحظة ان مجموع اجمالي جميع الأوراق يكون في ورقة data  في الخلية k1  شاكر تعاونكم معي كون الطلب لاحد أصدقاء اخواني في الله

جزاكم الله خيرا وبارك الله بكم

 

ترحيل الى اوراق متعددة.rar

[الـعيدروس]

الطلب غير واضح اخي الكريم

حط مثال للنتيجه في الورقتين 1 و 2

كي نفهم الطلب

[مصطفى محمود مصطفى]

السلام عليكم

الاستاذ ابو نصار جزاكم الله خيرا

عملت مثال لورقتين تم الترحيل يدوي

ووضعت بيانات جديدة هذه البيانات يتم ترحيلها الى ورقة جديدة

وهي حتما تكون رقم 3 اي تفتح ورقة جديدة وتاخذ الرقم الذي يلي السابقة

نقوم بترحيل البيانات كاملة ومسحها من ورقة data بنفس التنسيق ولكن بدون معادلات

مع الاحتفاظ بالمعادلات في ورقة data 

وكلما تم ترحيل بيانات جديدة في ورقة جديدة يتم اضافة مجموع الاجمالي

الى الخلية k1  في ورقة data

وفقكم الله وشاكرا تعاونكم معي

تحياتي

 

 

 

ترحيل الى اوراق متعددة.rar

[الـعيدروس]

Public Sub Ali_A()
   If Evaluate("CountA(A:A)") = 38 Then Ali_S
End Sub
Private Function Ali_S()
Dim Sh As Worksheet
Dim Sht As Worksheet
Dim Vl, a
Set Sht = Sheets("data")
'----------
Ap_Ali False
'----------
If Sheets.Count = 1 Then a = 1 Else a = Val(Sheets(Sheets.Count).Name + 1)
If IsError(Evaluate("'" & Nm & "'!A1")) Then
  Set Sh = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
With Sht
      .Range(.Cells(1, 1), .Cells(38, 8)).Copy
      Vl = CDbl(.Cells(38, 8))
  With Sh
      .Name = a
    With .Range("A1")
         .PasteSpecial xlPasteValues
         .PasteSpecial xlPasteColumnWidths
         .PasteSpecial xlPasteFormats
    End With
  End With
     .[K1] = (.[K1] + Vl)
     If MsgBox("هل تريد مسح البيانات المرحله ؟", vbYesNo, "تأكيد مسح") = vbYes Then _
    .Range("A2:H37").ClearContents
    .[A1].Select
End With
'----------
Ap_Ali True
'----------
Set Sh = Nothing
End If
End Function
Function Ap_Ali(Bll As Boolean)
 With Application
     .Calculation = IIf(Bll, -4105, -4135)
     .ScreenUpdating = Bll
     .EnableEvents = Bll
 End With
End Function

جرب الكود 

وهذا المرفق وبه الكود

 

 

ترحيل الى اوراق متعددة_111.rar

[مصطفى محمود مصطفى]

الاستاذ ابو نصار بارك الله بكم

وحفظكم من كل سوء

عمل ممتاز وكود رائع

لكم جزيل الشكر والتقدير

تحياتي