اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

لدي ورقة عمل فيها كشق ببيانات كل الصفوف في قائمة واحدة

هل يمكن عمل كود طباعة لكل صف في ورقة واحدة بزر واحد؟

مرفق ملف بالبيانات

طلاب.xlsx

  • أفضل إجابة
قام بنشر

لا حاجة لادراج آلاف الأسماء (عيّنه بسيطة تكفي)لأن الماكرو ديناميكي يأخذ كل الطلاب مهما كان عددهم

الكود

Option Explicit
Dim i
Dim arr(1 To 6)
Dim Ws As Worksheet
Dim New_sheet As Worksheet
Dim Rg As Range, Spes_Rg As Range, x%
'++++++++++++++++++++++++++++++++++++
Sub ADD_Sheet()
Set Ws = Sheets("KOUSHOUFAT")
arr(1) = "الأوّل": arr(2) = "الثّاني"
arr(3) = "الثّالث": arr(4) = "الرّابع"
arr(5) = "الخامس": arr(6) = "السّادس"
For i = LBound(arr) To UBound(arr)
  If Not Application.Evaluate("ISREF('" & _
     arr(i) & "'!A1)") Then
     Sheets.Add(, Sheets(Sheets.Count)).Name = arr(i)
  End If
Next
End Sub
'++++++++++++++++++++++++++++++++++++
Sub Get_Studiantes()

Application.ScreenUpdating = False
ADD_Sheet

Set Rg = Ws.Range("A1").CurrentRegion
i = 1
For Each New_sheet In Sheets
  If New_sheet.Name <> Ws.Name Then
   New_sheet.Range("A1").CurrentRegion.Clear
  Rg.AutoFilter 3, arr(i)
  Rg.SpecialCells(12).Copy
    With New_sheet.Range("A1")
    .PasteSpecial (8)
    .PasteSpecial (12)
    .PasteSpecial (4)
    End With
  Set Spes_Rg = New_sheet.Range("A1").CurrentRegion
  x = Spes_Rg.Rows.Count
  If x > 1 Then
    Spes_Rg.Cells(2, 1).Resize(x - 1).Value = _
    Evaluate("row(1:" & x - 1 & ")")
  End If
 i = i + 1
 End If
 
 Next
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
 Ws.Select
 Ws.AutoFilterMode = False

End Sub

الملف مرفق

 

jako.xlsm

  • Like 4
قام بنشر

 الأخ سليم حاصبيا

السلام عليكم، أرجو أن تكون بخير
الملف الذي أرسلته يرحل بيانات كل شعبة في ورقة عمل منفصلة
أنا أريد طباعتها تلقائيا بعد ترحيلها ثم حذف هذه الأوراق الجديدة بعد الطبع أو عند إغلاق الملف

هل ممكن ذلك؟ 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information