مطلوب مساعدة بخصوص الانتخابات

[الاهلاوى 2007]

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

الرجاء المساعدة فى نقل البيانات من ورقة 1 الى الورقة 2 كما هى مرتبة فى الورقة الثانية حتى نساهم فى العرس الانتخابى لمصرنا الحبية

ولو يوجد افضل من هذا فنتمى عدم البخل علينا

ولكم جزيل الشكر

تجربة2.xlsx

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

أهلاً وسهلاً بك و بأهل مصر (الحبيبة أم الدنيا) كلها

دعاؤكم للثورة اللّبنانية فقط (كما انتصرت عندكم تنتصر في وطني لبنان)

هذا الماكرو  (الملف مرفق ) فقط اضغط الزر "Get _Names"

Dim Source As Worksheet
Dim Target As Worksheet
Dim Simlpe As Worksheet
Dim i%, Cunt%, Ro%, k%, Position%, m%
'+++++++++++++++++++++++++++++++++
Sub debut()
Set Source = Sheets("Source")
Set Target = Sheets("Target")
Set Simple = Sheets("Simple")
End Sub
'+++++++++++++++++++++++++++++++++++
Sub copy_rg(ByVal src As Worksheet, _
ByVal Tg As Worksheet, ByVal Rg_name$, ByVal Rg_where$)
    src.Range(Rg_name).Copy

With Tg.Range(Rg_where)
  .PasteSpecial (xlPasteAll)
  .PasteSpecial (8)
End With
End Sub
'+++++++++++++++++++++++++++++++++++++++
Sub Copy_Tables()
debut
Target.Cells.Clear
Ro = Source.Cells(Rows.Count, 2).End(3).Row - 1
Cunt = Ro \ 2
If Cunt Mod 2 = 1 Then
 Cunt = Cunt + 1
End If
k = 1
  For i = 1 To Cunt
    Call copy_rg(Sheets("Simple"), Sheets("Target"), _
    "Simple_Rg", "B" & k)
  k = k + 6
  Next
  Application.CutCopyMode = False

End Sub
'++++++++++++++++++++++++++++++
Sub fil_data()
    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
    End With
   Copy_Tables
m = 1
For Position = 2 To Ro Step 2
 With Source.Cells(Position, 2).Resize(, 4)
    .Copy
    Target.Cells(m, 3).PasteSpecial _
    Paste:=12, Transpose:=True
    
    .Offset(1).Copy
      Target.Cells(m, 6).PasteSpecial _
      Paste:=12, Transpose:=True
 End With
 m = m + 6
Next
      With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .CutCopyMode = False
      End With
 Target.Cells(1, 2).Select
End Sub

الملف مرفق

Ahlawi.xlsm

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

تم التعديل قليلاً على الملف من حيث الطباعة( يقوم بطباعة كل 4 بيانات على ورقة مستقلة)
 الطباعة ديناميكية حسب عدد البيانات

Dim Source As Worksheet
Dim Target As Worksheet
Dim Simlpe As Worksheet
Dim i%, Cunt%, Ro%, k%, Position%, m%
'+++++++++++++++++++++++++++++++++
Sub debut()
Set Source = Sheets("Source")
Set Target = Sheets("Target")
Set Simple = Sheets("Simple")
End Sub
'+++++++++++++++++++++++++++++++++++
Sub copy_rg(ByVal src As Worksheet, _
ByVal Tg As Worksheet, ByVal Rg_name$, ByVal Rg_where$)
    src.Range(Rg_name).Copy

With Tg.Range(Rg_where)
  .PasteSpecial (xlPasteAll)
  .PasteSpecial (8)
End With
End Sub
'+++++++++++++++++++++++++++++++++++++++
Sub Copy_Tables()
debut
Target.Cells.Clear
Ro = Source.Cells(Rows.Count, 2).End(3).Row - 1
Cunt = (Ro \ 2) + 1
k = 1
  For i = 1 To Cunt
    Call copy_rg(Sheets("Simple"), Sheets("Target"), _
    "Simple_Rg", "B" & k)
  k = k + 7
  Next
  Application.CutCopyMode = False

End Sub
'++++++++++++++++++++++++++++++
Sub fil_data()
    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
    End With
   Copy_Tables
m = 1
For Position = 2 To Ro + 1 Step 2
 With Source.Cells(Position, 2).Resize(, 4)
    .Copy
    Target.Cells(m, 3).PasteSpecial _
    Paste:=12, Transpose:=True
    
    .Offset(1).Copy
      Target.Cells(m, 6).PasteSpecial _
      Paste:=12, Transpose:=True
 End With
 m = m + 7
Next
Print_areas
      With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .CutCopyMode = False
      End With
 Target.Cells(1, 2).Select
End Sub
'++++++++++++++++++++++++++++++++
Sub Print_areas()
Dim x, Rg_last As Range, y%
Dim k
Sheets("target").ResetAllPageBreaks
x = Sheets("target").Cells(Rows.Count, 2).End(3).Row
If x < 8 Then
Sheets("target").PageSetup.PrintArea = _
Sheets("target").Range("A1:F4").Address

Exit Sub
End If
      Set Rg_last = Sheets("target"). _
      Range("c" & x - 1).Resize(10).Find("*")
  If Not Rg_last Is Nothing Then
   y = Rg_last.Row + 1
  Else
   y = x - 6
  End If
  
Sheets("target").PageSetup.PrintArea = _
Sheets("target").Range("A1:F" & y).Address

For k = 13 To y Step 14
 Sheets("target").HPageBreaks.Add Before:=Rows(k + 1)
 Next
End Sub

الملف معدلاً

 

Ahlawi_New.xlsm

[الاهلاوى 2007]

و لن ترجع لبنان باريس الشرق كما كانت الا باتحاد اللبننيون

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

يارب احمى لبنا وشعب لبنا ومصر وشعب مصر

تقبل تحياتى

تحيا مصر ولبنا والامه العربية

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

استاذنا الاغالى

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

ونظرا لكثرة الاعداد فى الدائرة الواحةد هذا يكون مكلف

مثال

يوجد فى بلده واحده اكثر من 40000 صوت كيف يتم طباعتهم وكل 4 اسماء فى ورقة  لكن لو اصبحت 18 هذا افضل واقل تكلفة

 

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

للأسف فد جربت ما تريده

لكن لم استطع ان أحصل على اكثر من 14 اسم على ورقة واحدة (لأن البيانات تخرج منقسمة)

Ahlawi_New_14.xlsm

[yara ahmed]

اللهم انصر لبنان وأهل لبنان اللهم امين يارب

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

تم تضييق الهامشين (الأعلى والأسقل) قليلاً واصيح بالامكان العمل مع 16 اسم في كل ورقة

مما يوفر كمية لا باس بها من الورف (بالنسبة لـــ 40 الف اسم)   حوالي 350 ورقة

Ahlawi_New_16.xlsm

[الاهلاوى 2007]

الف شكر اخى الغالى بارك الله فيكم وبلبنان الحبيبة

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

أهلاً وسهلاً بكم 

لمزيد من الاناقة في اخراج الملف

تم وضع حدود تفصل الأسماء عن بعضها من اجل قص الأوراق بطريقة منتظمة عند الطباعة

اليك الملف من جدبد

Ahlawi_Super_16.xlsm