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

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


omhamzh
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

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

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

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

takrir.xlsx

رابط هذا التعليق
شارك

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

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

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

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

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

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

 

takrir.xlsx

رابط هذا التعليق
شارك

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

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

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

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

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

رابط هذا التعليق
شارك

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

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

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

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

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

  • Like 2
رابط هذا التعليق
شارك

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

  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

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

taadel.xlsm

تم تعديل بواسطه abouelhassan
رابط هذا التعليق
شارك

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

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

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

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

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

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

taadel.xlsm

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

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