تقرير بجدول من جداول

omhamzh · يونيو 7, 2020

السلام عليكم اساتذتى الاخوة الافاضل

احتاج مساعدة بكود جلب بيانات لتقرير من البيانات الموجودة بالصفحات بالكود مش بالمعادلات حتى لا يثقل الملف

عايزة اكتب رقم dtat3 في السطر 2 تحت العمود فيستدعى البيانات من الصفحات بالترتيب السطر الأول اسم الشيت الأول وباقى البيانات الموجودة في الشيت الأول الى السطر الاول
ثم لو موجود الرقم في الصفحة 3 أيضا يبقى السطر التالى يحضر اسم الشيت وباقى البيانات في هذا الجدول

مشكورين اخواتى

takrir.xlsx

omhamzh · يونيو 7, 2020

الله يفتح عليك ينقصه حاجة بسيطة

تحديد رقم بس فى الخلية d2 يجلب بيانات هذا الرقم

بمعنى عايزة اكتب رقم dtat3 في السطر 2 تحت العمود فيستدعى البيانات من الصفحات بالترتيب السطر الأول اسم الشيت الأول وباقى البيانات الموجودة في الشيت الأول الى السطر الاول
ثم لو موجود الرقم في الصفحة 3 أيضا يبقى السطر التالى يحضر اسم الشيت وباقى البيانات في هذا الجدول

يعنى حضرتك انظر هتلاقينى كاتبة 1200 وهو الرقم المطلوب استدعاء البيانات له

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

تسلم ايدك ربنا يحفظك يااارب ما نتحرم منك ابدااااا

takrir.xlsx

**سليم حاصبيا** · يونيو 8, 2020

تم معالجة الأمر

1- ليس هناك من ضرورة لتلوين اي حلية لاحتيار التكرار

2-عند تشغيل الكود تظهر لك رسالة تطلب تحديد عدد التكرار (بين 1 و 9)

Option Explicit

Sub Get_data()
Dim Tar As Worksheet, SH As Worksheet
Dim Rg As Range, Rg_Sh As Range
Dim Full_Rg As Range
Dim Sing_Cel As Range
Dim max_Col%, max_Ro%, m%, k%, t%, Ro%
Dim Bol As Boolean
Dim Fin_Rg As Range

Set Tar = Sheets("takrir")
Ro = Tar.Cells(Rows.Count, 2).End(3).Row
If Ro < 2 Then Ro = 2
Tar.Range("A2:J" & Ro).Clear
k = Application.InputBox("How Many Times", Type:=2)
If k < 1 Or k > 9 Then
  MsgBox "Your number must be betwenn 1 and 9"
  Exit Sub
End If

For Each SH In Sheets
 If SH.Name <> Tar.Name Then
  Set Rg_Sh = SH.Range("A1").CurrentRegion
   If Rg_Sh.Rows.Count = 1 Then GoTo Next_SH
    Set Rg_Sh = Rg_Sh.Offset(1) _
    .Resize(Rg_Sh.Rows.Count - 1)
   max_Col = Rg_Sh.Columns.Count
   max_Ro = Rg_Sh.Rows.Count
       m = Tar.Cells(Rows.Count, 2) _
       .End(3).Row + IIf(Not Bol, 1, 2)
      Bol = True
   Tar.Cells(m, 1) = SH.Name
   For t = 1 To k
    Tar.Cells(m, 2).Resize(max_Ro, max_Col).Value = _
    SH.Cells(2, 1).Resize(max_Ro, max_Col).Value
    m = Tar.Cells(Rows.Count, 2).End(3).Row + 1
   Next t
 End If
 Set Fin_Rg = Tar.Range("A:A").Find(SH.Name, lookat:=1)
  If Not Fin_Rg Is Nothing Then
      With Fin_Rg.Resize(max_Ro * k, 1)
      .Merge
      .VerticalAlignment = 2
      End With
  End If
Next_SH:
 Next SH
 m = Tar.Cells(Rows.Count, 2).End(3).Row
  If m = 2 Then Exit Sub
Set Full_Rg = Tar.Range("A2:J" & m)
With Full_Rg
.InsertIndent 1
.Borders.LineStyle = 1
.Font.Bold = True: .Font.Size = 16
.Interior.ColorIndex = 35
  For Each Sing_Cel In .Columns(2).SpecialCells(4)
   Sing_Cel.Offset(, -1).Resize(, max_Col + 1) _
   .Interior.ColorIndex = 6
  Next
End With
End Sub

الملف مرفق

data_by_number.xlsm

omhamzh · يونيو 8, 2020

الف الف الف شكر اخى الكريم الغالى استاذ سليم

بس انا مش عارفة أو مش فاهمة آلية العمل يعنى ازى عدد التكرار المطلوب

انا عايزة مثلا رقم 1200اكتب ايه 1ولا ايه ما انا مش ببقى عارفة عدد الشيتس

انا والله والله مش بحب تتضايق ولا حد من الإدارة يتضايق ومش بعرف اعدل الاكواد علشان كده بسال حضرتك يا استاذ يا كبير يا اخى

معلش انا مش عارفة اطلع تقرير لرقم بعينه

انا بيطلع لى كل الارقام وكل الشيتات

ربنا يحفظك يارب ويديك الصحة والعافية ويجعله

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

**سليم حاصبيا** · يونيو 8, 2020

انا مش فاهم انت عايزه ايه بالضبط

عندما تختارين العدد المطلوب من خلال الــــ Input Box يتم تكرار بيانات كل صفخة حسب العدد الذي أخترته (هكذا انا فهمت من سؤالك)

يرجى ادراج ملف لا يتعدى الثلاث صفحات كلها مليانة Data (على الأكثر 10 صفوف / لا يكفي صفين )

الــ Data يجب ان تكون مختلفة ليست كلها (مصطفى و سليم و الح...)

و صفحة مستقلة تكتبين فيها يدوياً كل النتائج التي تتوقعين ان تحصلي عليها

omhamzh · يونيو 8, 2020

اشكرك استاذ ى

انا كتبت لحضرتك بالتفصيل جدا سامحنى معلش احتاج هذا التقرير

ربنا يحفظك يارب

takrir.xlsx

**سليم حاصبيا** · يونيو 8, 2020

1-كالعادة أول صف قبل الجدول الصف رقم 3 فارغ تماماً

2-يمكنك ادراج الرقم المطلوب ليس فقط في الخلية D2 بل في اي خلية من C2 الى J2 شرط ادراج رقم واحد فقط ( أعني C2 فقط أو F2 فقط أو G2 فقط الخ...)

3- في حال تكرر الرقم المطلوب في نفس الصفحة لا يتعاضى عنه الماكرو

(مثلاً الرفم 500 موجود في Sheet1 مرتين وفي Last مرة واحدة )

جربي اكتبي 500 وانقري على الزر

الماكرو

Option Explicit

Sub My_FindNext()
    Dim T As Worksheet, Sh As Worksheet
    Dim Opt_rg As Range, Sing_cel As Range
    Dim Find_Range, SH_rg As Range
    Dim My_rg As Range
    Dim Ro1%, m%, RO%, col%
    Dim mot
    Dim x As Boolean
  
Set T = Sheets("takrir")
RO = T.Cells(Rows.Count, 2).End(3).Row
If RO < 4 Then RO = 4
T.Range("A4:j" & RO + 1).Clear
Set Find_Range = T.Range("a2:J2").Find("*", Lookat:=1)
If Find_Range Is Nothing Then
 MsgBox "not Found"
 Exit Sub
End If
m = 4
mot = Find_Range.Value: col = Find_Range.Column - 1
 For Each Sh In Sheets
  If Sh.Name = T.Name Then GoTo Next_Sheet
  Set SH_rg = Sh.Range("A1").CurrentRegion.Columns(col)
  Set Find_Range = SH_rg.Find(mot, Lookat:=1)
Do While Not Find_Range Is Nothing
        If Not x Then
         Ro1 = Find_Range.Row
         x = True
        End If
       '==============================================
    If Opt_rg Is Nothing Then
      Set Opt_rg = Sh.Cells(Find_Range.Row, 1).Resize(, 9)
    Else
      Set Opt_rg = Union(Opt_rg, Sh.Cells(Find_Range.Row, 1).Resize(, 9))
    End If
     Set Find_Range = SH_rg.FindNext(Find_Range)
     If Find_Range.Row = Ro1 Then Exit Do
Loop
  If Not Opt_rg Is Nothing Then
  Opt_rg.Copy
  T.Cells(m, 2).PasteSpecial (12)
  T.Cells(m, 1) = Sh.Name
  Set Opt_rg = Nothing: m = T.Cells(Rows.Count, 2).End(3).Row + 2
  Application.CutCopyMode = False
  x = False
  End If
   '========================================
Next_Sheet:
 Next Sh
    If m = 4 Then
      MsgBox "No Found Data"
      Exit Sub
    End If
T.Rows(m - 1).Clear
 With T.Range("A4:J" & m - 2)
 .Borders.LineStyle = 1: .InsertIndent 1
 .Font.Bold = True: .Font.Size = 14
 .Interior.ColorIndex = 19
 On Error Resume Next
  For Each Sing_cel In .Columns(2).SpecialCells(4)
   Sing_cel.Offset(, -1).Resize(, 10) _
   .Interior.ColorIndex = 35
 Next Sing_cel
 End With
T.Activate: T.Range("A4").Select
End Sub

الملف

OmHamza.xlsm

omhamzh · يونيو 8, 2020

الله حضرتك اجدع اخ والله ربنا مايحرمنى منك

وربنا يراضيك زى ما بتراضينا وربنا يحفظك لينا يارب

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

انا يعجز لسانى عن شكرك اقسم بالله يا اطيب انسان يا استاذ سليم اكثر الله خيرك ياااااااااااااارب

اشكرك والله من قلبى شكراااااااااااااااا

**abouelhassan** · يونيو 8, 2020

ربنا يكرمك يا استاذ سليم اللهم امين

بارك الله فيك

احترامى

**abouelhassan** · يونيو 13, 2020

ممكن توضيح استاذ سليم

حاولت استفيد من الكود

ممكن توضيح كيف يمكن التعديل عليه ليستدعى بيانات من الشيتات من الصف5 وليس الاول وكمان

هل بالامكان استثناء صفحات من الاستدعاء مثل صفحة اسمهاdata ,datac عندما غيرت a1 الى a5 نسخ لى بيانات الصفحة

مع الشكر والنقدير

taadel.xlsm

تم تعديل يونيو 13, 2020 بواسطه abouelhassan

**سليم حاصبيا** · يونيو 13, 2020

من أجل استثناء صفحات مغينة يمكن اضافة على الكود ما يلي

حسب الصورة المرفق

abuhasan.png.c8cb4efeff0480ae213cbe3a514bfd37.png

**abouelhassan** · يونيو 13, 2020

تم كتابة التعديل استاذى

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

كيف يتم التعديل للاستدعاء من الصف الخامس وليس الاول واكن شاكر فضلك حيث اننى اغير a1 الى a5 يقف الكود

عندما غيرت النطاق منa1:j2 الى a1:j5

ايضا توقف معلش انا حابب اتعلم لان هذا الكود جميل ومفيد

مع تحياتى وتقديرى

taadel.xlsm

**سليم حاصبيا** · يونيو 13, 2020

يجب وضع هذا ايضاً مع فقرات الــ Dim

توقف الكود بسببها

Dim Match As Boolean

**abouelhassan** · يونيو 13, 2020

تمام استاذنا الله يحفظك صح بس مش عارف اعدل تغير نطاق الاستدعاء

كل ما اغير يظهر لى رسالة no data fond

احترامى وتقديرى

**سليم حاصبيا** · يونيو 13, 2020

تم التعديل على الكود ليحلب البيانات من أي صف و ليس الخامس فقط

Option Explicit

Sub My_FindNext()
    Dim T As Worksheet, Sh As Worksheet
    Dim Opt_rg As Range, Sing_cel As Range
    Dim Find_Range, SH_rg As Range
    Dim My_rg As Range
    Dim Ro1%, m%, RO%, col%
    Dim mot
    Dim x As Boolean
    Dim Match As Boolean
  Dim arr(1 To 3)
  arr(1) = "data": arr(2) = "datac": arr(3) = "takrir":
Set T = Sheets("takrir")
RO = T.Cells(Rows.Count, 2).End(3).Row
If RO < 4 Then RO = 4
T.Range("A4:j" & RO + 1).Clear
Set Find_Range = T.Range("a2:J2").Find("*", Lookat:=1)
If Find_Range Is Nothing Then
 MsgBox "not Found"
 Exit Sub
End If
m = 4
mot = Find_Range.Value: col = Find_Range.Column - 1
 For Each Sh In Sheets

Match = IsError(Application.Match(Sh.Name, arr, 0))
If Not Match Then GoTo Next_Sheet

  Set SH_rg = Sh.Range("A1:I10000").Columns(col)

  Set Find_Range = SH_rg.Find(mot, Lookat:=1)
  If Find_Range Is Nothing Then GoTo Next_Sheet
  
Do While Not Find_Range Is Nothing
        If Not x Then
         Ro1 = Find_Range.Row
         x = True
        End If
       '==============================================
    If Opt_rg Is Nothing Then
      Set Opt_rg = Sh.Cells(Find_Range.Row, 1).Resize(, 9)
    Else
      Set Opt_rg = Union(Opt_rg, Sh.Cells(Find_Range.Row, 1).Resize(, 9))
    End If
     Set Find_Range = SH_rg.FindNext(Find_Range)
     If Find_Range.Row = Ro1 Then Exit Do
Loop
  If Not Opt_rg Is Nothing Then
  
  Opt_rg.Copy
  T.Cells(m, 2).PasteSpecial (12)
  T.Cells(m, 1) = Sh.Name
  Set Opt_rg = Nothing: m = T.Cells(Rows.Count, 2).End(3).Row + 2
  Application.CutCopyMode = False
  x = False
  End If
   '========================================
Next_Sheet:
 Next Sh
    If m = 4 Then
      MsgBox "No Found Data"
      Exit Sub
    End If
T.Rows(m - 1).Clear
 With T.Range("A4:J" & m - 2)
 .Borders.LineStyle = 1: .InsertIndent 1
 .Font.Bold = True: .Font.Size = 14
 .Interior.ColorIndex = 19
 On Error Resume Next
  For Each Sing_cel In .Columns(2).SpecialCells(4)
   Sing_cel.Offset(, -1).Resize(, 10) _
   .Interior.ColorIndex = 35
 Next Sing_cel
 End With
T.Activate: T.Range("A4").Select
End Sub

Abou hasan_ta33dil.xlsm

**abouelhassan** · يونيو 13, 2020

ممتاز حضرتك ممتاز والله ربنا يحفظك ماشاء الله عليك استاذ سليم

ربنا يرضى عنك

كل الشكر والتقدير والاحترام من اخيك

تسجيل الدخول

تقرير بجدول من جداول

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

omhamzh

omhamzh

سليم حاصبيا

omhamzh

سليم حاصبيا

omhamzh

سليم حاصبيا

omhamzh

abouelhassan

abouelhassan

سليم حاصبيا

abouelhassan

سليم حاصبيا

abouelhassan

سليم حاصبيا

abouelhassan

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information